Context Navigation

Back to Ticket #1114

Ticket #1114: perl_to_pir_v2.patch

File perl_to_pir_v2.patch, 160.2 KB (added by mgrimes, 12 years ago)

t/op/string.t


1		#!~~perl~~
	1	#! parrot
2	2	# Copyright (C) 2001-2009, Parrot Foundation.
3	3	# $Id$
4	4
5		~~use strict;~~
6		~~use warnings;~~
7		~~use lib qw( . lib ../lib ../../lib );~~
8
9		~~use Test::More;~~
10		~~use Parrot::Test tests => 167;~~
11		~~use Parrot::Config;~~
12
13	5	=head1 NAME
14	6
15	7	t/op/string.t - Parrot Strings
…	…
24	16
25	17	=cut
26	18
27		pasm_output_is( <<'CODE', <<'OUTPUT', 'set_s_s\|sc' );
28		set S4, "JAPH\n"
29		set S5, S4
30		print S4
31		print S5
32		end
33		CODE
34		JAPH
35		JAPH
36		OUTPUT
	19	.sub main :main
	20	.include 'test_more.pir'
37	21
38		pasm_output_is( <<'CODE', <<'OUTPUT', 'clone' );
39		set S0, "Foo\n"
40		clone S1, S0
41		print S0
42		print S1
	22	plan(405)
43	23
44		clone S1, "Bar\n"
45		print S1
46		chopn S1, 1 # Check that the contents of S1 are no longer constant
47		print S1
48		print "\n"
	24	set_s_s_sc()
	25	test_clone()
	26	clone_null()
	27	test_length_i_s()
	28	zero_length_substr()
	29	chopn_with_clone()
	30	chopn_with_set()
	31	chopn_oob_values()
	32	three_argument_chopn()
	33	three_argument_chopn__oob_values()
	34	substr_tests()
	35	neg_substr_offset()
	36	exception_substr_oob()
	37	exception_substr_oob()
	38	len_greater_than_strlen()
	39	len_greater_than_strlen_neg_offset()
	40	five_arg_substr_w_rep_eq_length()
	41	five_arg_substr_w_replacement_gt_length()
	42	five_arg_substr_w_replacement_lt_length()
	43	five_arg_substr__offset_at_end_of_string()
	44	exception_five_arg_substr__offset_past_end_of_string()
	45	five_arg_substr_neg_offset_repl_eq_length()
	46	five_arg_substr_neg_offset_repl_gt_length()
	47	five_arg_substr_neg_offset_repl_lt_length()
	48	exception_five_arg_substr_neg_offset_out_of_string()
	49	five_arg_substr_length_gt_strlen()
	50	five_arg_substr_length_gt_strlen_neg_offset()
	51	four_arg_replacement_only_substr()
	52	three_arg_substr()
	53	exception_substr__pos_offset_zero_length_string()
	54	substr_offset_zero_zero_length_string()
	55	exception_substr_offset_one_zero_length_string()
	56	exception_substr_neg_offset_zero_length_string()
	57	zero_length_substr_zero_length_string()
	58	zero_length_substr_zero_length_string()
	59	three_arg_substr_zero_length_string()
	60	five_arg_substr_zero_length_string()
	61	four_arg_substr_replace_zero_length_string()
	62	concat_s_s_sc_null_onto_null()
	63	concat_s_sc_repeated_two_arg_concats()
	64	concat_s_s_sc_foo_one_onto_null()
	65	test_concat_s_s_sc()
	66	concat_s_s_sc_s_sc()
	67	concat_ensure_copy_is_made()
	68	test_clears()
49	69
50		end
51		CODE
52		Foo
53		Foo
54		Bar
55		Bar
56		OUTPUT
	70	same_constant_twice_bug()
	71	exception_two_param_ord_empty_string()
	72	exception_two_param_ord_empty_string_register()
	73	exception_three_param_ord_empty_string()
	74	exception_three_param_ord_empty_string_register()
	75	two_param_ord_one_character_string()
	76	two_param_ord_multi_character_string()
	77	two_param_ord_one_character_string_register()
	78	three_param_ord_one_character_string()
	79	three_param_ord_one_character_string_register()
	80	three_param_ord_multi_character_string()
	81	three_param_ord_multi_character_string_register()
	82	exception_three_param_ord_multi_character_string()
	83	exception_three_param_ord_multi_character_string()
	84	three_param_ord_one_character_string_from_end()
	85	three_param_ord_one_character_string_register_from_end()
	86	three_param_ord_multi_character_string_from_end()
	87	three_param_ord_multi_character_string_register_from_end()
	88	exception_three_param_ord_multi_character_string_register_from_end_oob()
	89	chr_of_thirty_two_is_space_in_ascii()
	90	chr_of_sixty_five_is_a_in_ascii()
	91	chr_of_one_hundred_and_twenty_two_is_z_in_ascii()
	92	test_if_s_ic()
	93	repeat_s_s_sc_i_ic()
	94	exception_repeat_oob()
	95	exception_repeat_oob_repeat_p_p_p()
	96	exception_repeat_oob_repeate_p_p_i()
	97	encodingname_oob()
	98	index_three_arg_form()
	99	index_four_arg_form()
	100	index_four_arg_form_bug_twenty_two_thousand_seven_hundred_and_eighteen()
	101	index_null_strings()
	102	index_embedded_nulls()
	103	index_big_strings()
	104	index_big_hard_to_match_strings()
	105	index_with_different_charsets()
	106	negative_index_bug_35959()
	107	index_multibyte_matching()
	108	index_multibyte_matching_two()
	109	num_to_string()
	110	string_to_int()
	111	concat_or_substr_cow()
	112	constant_to_cstring()
	113	cow_with_chopn_leaving_original_untouched()
	114	check_that_bug_bug_16874_was_fixed()
	115	stress_concat()
	116	ord_and_substring_see_bug_17035()
57	117
58		pasm_output_is( <<'CODE', <<'OUTPUT', 'clone null' );
59		null S0
60		clone S1, S0
61		end
62		CODE
63		OUTPUT
	118	test_sprintf()
	119	other_form_of_sprintf_op()
	120	sprintf_left_justify()
	121	correct_precision_for_sprintf_x()
	122	test_exchange()
	123	test_find_encoding()
	124	test_string_encoding()
	125	test_assign()
	126	assign_and_globber()
	127	assign_and_globber_2()
	128	bands_null_string()
	129	bands_2()
	130	bands_3()
	131	bands_cow()
	132	bors_null_string()
	133	bors_2()
	134	bors_3()
	135	bors_cow()
	136	bxors_null_string()
	137	bxors_2()
	138	bxors_3()
	139	bxors_cow()
	140	bnots_null_string()
	141	bnots_2()
	142	bnots_cow()
	143	transcode_to_utf8()
	144	string_chartype()
	145	split_on_empty_string()
	146	split_on_non_empty_string()
	147	test_join()
	148	eq_addr_or_ne_addr()
	149	test_if_null_s_ic()
	150	test_upcase()
	151	test_downcase()
	152	test_titlecase()
	153	three_param_ord_one_character_string_register_i()
	154	three_param_ord_multi_character_string_i()
	155	three_param_ord_multi_character_string_register_i()
	156	exception_three_param_ord_multi_character_string_i()
	157	exception_three_param_ord_multi_character_string_i()
	158	three_param_ord_one_character_string_from_end_i()
	159	three_param_ord_one_character_string_register_from_end_i()
	160	three_param_ord_multi_character_string_from_end_i()
	161	three_param_ord_multi_character_string_register_from_end_i()
	162	exception_three_param_ord_multi_character_string_register_from_end_oob_i()
	163	more_string_to_int()
	164	constant_string_and_modify_in_situ_op_rt_bug_60030()
	165	corner_cases_of_numification()
	166	non_canonical_nan_and_inf()
	167	split_hll_mapped()
	168	# END_OF_TESTS
	169	join_get_string_returns_a_null_string()
64	170
65		pasm_output_is( <<'CODE', '4', 'length_i_s' );
66		set I4, 0
67		set S4, "JAPH"
68		length I4, S4
69		print I4
70		end
71		CODE
	171	.end
72	172
73		pasm_output_is( <<'CODE', '0', '0 length substr' );
74		set I4, 0
75		set S4, "JAPH"
76		substr S3, S4, 1, 0
77		length I4, S3
78		print I4
79		end
80		CODE
	173	.macro exception_is ( M )
	174	.local pmc exception
	175	.local string message
	176	.get_results (exception)
81	177
82		pasm_output_is( <<'CODE', <<'OUTPUT', 'chopn with clone' );
83		set S4, "JAPHxyzw"
84		set S5, "japhXYZW"
85		clone S3, S4
86		set S1, "\n"
87		set I1, 4
88		chopn S4, 3
89		chopn S4, 1
90		chopn S5, I1
91		print S4
92		print S1
93		print S5
94		print S1
95		print S3
96		print S1
97		end
98		CODE
99		JAPH
100		japh
101		JAPHxyzw
102		OUTPUT
	178	message = exception['message']
	179	is( message, .M, .M )
	180	.endm
103	181
104		pasm_output_is( <<'CODE', <<'OUTPUT', 'chopn with set' );
105		set S4, "JAPHxyzw"
106		set S5, "japhXYZW"
107		set S3, S4
108		set S1, "\n"
109		set I1, 4
110		chopn S4, 3
111		chopn S4, 1
112		chopn S5, I1
113		print S4
114		print S1
115		print S5
116		print S1
117		print S3
118		print S1
119		end
120		CODE
121		JAPH
122		japh
123		JAPH
124		OUTPUT
	182	.sub set_s_s_sc
	183	set $S4, "JAPH"
	184	set $S5, $S4
	185
	186	is( $S4, "JAPH", '' )
	187	is( $S5, "JAPH", '' )
	188	.end
	189
	190	.sub test_clone
	191	set $S0, "Foo1"
	192	clone $S1, $S0
	193
	194	is( $S0, "Foo1", '' )
	195	is( $S1, "Foo1", '' )
	196
	197	clone $S1, "Bar1"
	198	is( $S1, "Bar1", '' )
125	199
126		pasm_output_is( <<'CODE', <<'OUTPUT', 'chopn, OOB values' );
127		set S1, "A string of length 21"
128		chopn S1, 0
129		print S1
130		print "\n"
131		chopn S1, 4
132		print S1
133		print "\n"
134		# -length cuts now
135		chopn S1, -4
136		print S1
137		print "\n"
138		chopn S1, 1000
139		print S1
140		print " nothing \n"
141		end
142		CODE
143		A string of length 21
144		A string of lengt
145		A st
146		nothing
147		OUTPUT
	200	chopn $S1, 1
	201	is( $S1, "Bar", 'the contents of $S1 are no longer constant' )
	202	.end
	203
	204	.sub clone_null
	205	null $S0
	206	clone $S1, $S0
	207	is( $S1, $S0, '' )
	208	.end
148	209
149		pasm_output_is( <<'CODE', <<'OUTPUT', 'Three argument chopn' );
150		set S1, "Parrot"
	210	.sub test_length_i_s
	211	set $I4, 0
	212	set $S4, "JAPH"
	213	length $I4, $S4
	214	is( $I4, "4", '' )
	215	.end
151	216
152		chopn S2, S1, 0
153		print S1
154		print "\n"
155		print S2
156		print "\n"
	217	.sub zero_length_substr
	218	set $I4, 0
	219	set $S4, "JAPH"
	220	substr $S3, $S4, 1, 0
	221	length $I4, $S3
	222	is( $I4, "0", '' )
	223	.end
157	224
158		chopn S2, S1, 1
159		print S1
160		print "\n"
161		print S2
162		print "\n"
	225	.sub chopn_with_clone
	226	set $S4, "JAPHxyzw"
	227	set $S5, "japhXYZW"
	228	clone $S3, $S4
	229	set $I1, 4
	230	chopn $S4, 3
	231	chopn $S4, 1
	232	chopn $S5, $I1
163	233
164		set I0, 2
165		chopn S2, S1, I0
166		print S1
167		print "\n"
168		print S2
169		print "\n"
	234	is( $S4, "JAPH", '' )
	235	is( $S5, "japh", '' )
	236	is( $S3, "JAPHxyzw", '' )
	237	.end
	238
	239	.sub chopn_with_set
	240	set $S4, "JAPHxyzw"
	241	set $S5, "japhXYZW"
	242	set $S3, $S4
	243	set $I1, 4
	244	chopn $S4, 3
	245	chopn $S4, 1
	246	chopn $S5, $I1
170	247
171		chopn S2, "Parrot", 3
172		print S2
173		print "\n"
	248	is( $S4, "JAPH", '' )
	249	is( $S5, "japh", '' )
	250	is( $S3, "JAPH", '' )
	251	.end
174	252
175		chopn S1, S1, 5
176		print S1
177		print "\n"
	253	.sub chopn_oob_values
	254	set $S1, "A string of length 21"
	255	chopn $S1, 0
	256	is( $S1, "A string of length 21", '' )
178	257
179		set S1, "Parrot"
180		set S3, S1
181		chopn S2, S1, 3
182		print S3
183		print "\n"
	258	chopn $S1, 4
	259	is( $S1, "A string of lengt", '' )
184	260
185		set S3, S1
186		chopn S1, 3
187		print S3
188		print "\n"
	261	# -length cuts now
	262	chopn $S1, -4
	263	is( $S1, "A st", '' )
189	264
190		end
191		CODE
192		Parrot
193		Parrot
194		Parrot
195		Parro
196		Parrot
197		Parr
198		Par
199		P
200		Parrot
201		Par
202		OUTPUT
	265	chopn $S1, 1000
	266	is( $S1, "", '' )
	267	.end
	268
	269	.sub three_argument_chopn
	270	set $S1, "Parrot"
	271	chopn $S2, $S1, 0
	272	is( $S1, "Parrot", '' )
	273	is( $S2, "Parrot", '' )
	274
	275	chopn $S2, $S1, 1
	276	is( $S1, "Parrot", '' )
	277	is( $S2, "Parro", '' )
	278
	279	set $I0, 2
	280	chopn $S2, $S1, $I0
	281	is( $S1, "Parrot", '' )
	282	is( $S2, "Parr", '' )
	283
	284	chopn $S2, "Parrot", 3
	285	is( $S2, "Par", '' )
	286
	287	chopn $S1, $S1, 5
	288	is( $S1, "P", '' )
	289
	290	set $S1, "Parrot"
	291	set $S3, $S1
	292	chopn $S2, $S1, 3
	293	is( $S3, "Parrot", '' )
	294
	295	set $S3, $S1
	296	chopn $S1, 3
	297	is( $S3, "Par", '' )
	298	.end
	299	#
	300	.sub three_argument_chopn__oob_values
	301	set $S1, "Parrot"
	302	chopn $S2, $S1, 7
	303	is( $S1, "Parrot", '' )
	304	is( $S2, "", '' )
	305
	306	chopn $S2, $S1, -1
	307	is( $S1, "Parrot", '' )
	308	is( $S2, "P", '' )
	309	.end
203	310
204		pasm_output_is( <<'CODE', <<'OUTPUT', 'Three argument chopn, OOB values' );
205		set S1, "Parrot"
	311	.sub substr_tests
	312	set $S4, "12345JAPH01"
	313	set $I4, 5
	314	set $I5, 4
206	315
207		chopn S2, S1, 7
208		print S1
209		print "\n"
210		print S2
211		print "\n"
	316	substr $S5, $S4, $I4, $I5
	317	is( $S5, "JAPH", '' )
212	318
213		chopn S2, S1, -1
214		print S1
215		print "\n"
216		print S2
217		print "\n"
	319	substr $S5, $S4, $I4, 4
	320	is( $S5, "JAPH", '' )
218	321
219		end
220		CODE
221		Parrot
	322	substr $S5, $S4, 5, $I5
	323	is( $S5, "JAPH", '' )
222	324
223		Parrot
224		P
225		OUTPUT
	325	substr $S5, $S4, 5, 4
	326	is( $S5, "JAPH", '' )
226	327
227		pasm_output_is( <<'CODE', <<'OUTPUT', 'substr_s_s\|sc_i\|ic_i\|ic' );
228		set S4, "12345JAPH01"
229		set I4, 5
230		set I5, 4
231		substr S5, S4, I4, I5
232		print S5
233		substr S5, S4, I4, 4
234		print S5
235		substr S5, S4, 5, I5
236		print S5
237		substr S5, S4, 5, 4
238		print S5
239		substr S5, "12345JAPH01", I4, I5
240		print S5
241		substr S5, "12345JAPH01", I4, 4
242		print S5
243		substr S5, "12345JAPH01", 5, I5
244		print S5
245		substr S5, "12345JAPH01", 5, 4
246		print S5
247		print "\n"
248		end
249		CODE
250		JAPHJAPHJAPHJAPHJAPHJAPHJAPHJAPH
251		OUTPUT
	328	substr $S5, "12345JAPH01", $I4, $I5
	329	is( $S5, "JAPH", '' )
252	330
253		# negative offsets
254		pasm_output_is( <<'CODE', <<'OUTPUT', 'neg substr offset' );
255		set S0, "A string of length 21"
256		set I0, -9
257		set I1, 6
258		substr S1, S0, I0, I1
259		print S0
260		print "\n"
261		print S1
262		print "\n"
263		end
264		CODE
265		A string of length 21
266		length
267		OUTPUT
	331	substr $S5, "12345JAPH01", $I4, 4
	332	is( $S5, "JAPH", '' )
268	333
	334	substr $S5, "12345JAPH01", 5, $I5
	335	is( $S5, "JAPH", '' )
	336
	337	substr $S5, "12345JAPH01", 5, 4
	338	is( $S5, "JAPH", '' )
	339	.end
	340
	341	# negative offsets
	342	.sub neg_substr_offset
	343	set $S0, "A string of length 21"
	344	set $I0, -9
	345	set $I1, 6
	346	substr $S1, $S0, $I0, $I1
	347	is( $S0, "A string of length 21", '' )
	348	is( $S1, "length", '' )
	349	.end
	350
269	351	# This asks for substring that shouldn't be allowed...
270		pasm_error_output_like( <<'CODE', <<'OUTPUT', 'substr OOB' );
271		set S0, "A string of length 21"
272		set I0, -99
273		set I1, 6
274		~~substr S1, S0, I0, I1~~
275		~~end~~
276		CODE
277		/^Cannot take substr outside string/
278		OUTPUT
	352	.sub exception_substr_oob
	353	set $S0, "A string of length 21"
	354	set $I0, -99
	355	set $I1, 6
	356	push_eh handler
	357	substr $S1, $S0, $I0, $I1
	358	handler:
	359	.exception_is( "Cannot take substr outside string" )
	360	.end
279	361
280	362	# This asks for substring that shouldn't be allowed...
281		pasm_error_output_like( <<'CODE', <<'OUTPUT', 'substr OOB' );
282		set S0, "A string of length 21"
283		set I0, 99
284		set I1, 6
285		~~substr S1, S0, I0, I1~~
286		~~end~~
287		CODE
288		/^Cannot take substr outside string/
289		OUTPUT
	363	.sub exception_substr_oob
	364	set $S0, "A string of length 21"
	365	set $I0, 99
	366	set $I1, 6
	367	push_eh handler
	368	substr $S1, $S0, $I0, $I1
	369	handler:
	370	.exception_is( "Cannot take substr outside string" )
	371	.end
290	372
291	373	# This asks for substring much greater than length of original string
292		pasm_output_is( <<'CODE', <<'OUTPUT', 'len>strlen' );
293		set S0, "A string of length 21"
294		set I0, 12
295		set I1, 1000
296		substr S1, S0, I0, I1
297		print S0
298		print "\n"
299		print S1
300		print "\n"
301		end
302		CODE
303		A string of length 21
304		length 21
305		OUTPUT
	374	.sub len_greater_than_strlen
	375	set $S0, "A string of length 21"
	376	set $I0, 12
	377	set $I1, 1000
	378	substr $S1, $S0, $I0, $I1
	379	is( $S0, "A string of length 21", '' )
	380	is( $S1, "length 21", '' )
	381	.end
306	382
307	383	# The same, with a negative offset
308		pasm_output_is( <<'CODE', <<'OUTPUT', 'len>strlen, -ve os' );
309		set S0, "A string of length 21"
310		set I0, -9
311		set I1, 1000
312		substr S1, S0, I0, I1
313		print S0
314		print "\n"
315		print S1
316		print "\n"
317		end
318		CODE
319		A string of length 21
320		length 21
321		OUTPUT
	384	.sub len_greater_than_strlen_neg_offset
	385	set $S0, "A string of length 21"
	386	set $I0, -9
	387	set $I1, 1000
	388	substr $S1, $S0, $I0, $I1
	389	is( $S0, "A string of length 21", '' )
	390	is( $S1, "length 21", '' )
	391	.end
	392
	393	.sub five_arg_substr_w_rep_eq_length
	394	set $S0, "abcdefghijk"
	395	set $S1, "xyz"
	396	substr $S2, $S0, 4, 3, $S1
	397	is( $S0, "abcdxyzhijk", '' )
	398	is( $S1, "xyz", '' )
	399	is( $S2, "efg", '' )
	400	.end
322	401
323		pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, replacement = length' );
324		set S0, "abcdefghijk"
325		set S1, "xyz"
326		substr S2, S0, 4, 3, S1
327		print S0
328		print "\n"
329		print S1
330		print "\n"
331		print S2
332		print "\n"
333		end
334		CODE
335		abcdxyzhijk
336		xyz
337		efg
338		OUTPUT
	402	.sub five_arg_substr_w_replacement_gt_length
	403	set $S0, "abcdefghijk"
	404	set $S1, "xyz0123"
	405	substr $S2, $S0, 4, 3, $S1
	406	is( $S0, "abcdxyz0123hijk", '' )
	407	is( $S1, "xyz0123", '' )
	408	is( $S2, "efg", '' )
	409	.end
339	410
340		pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, replacement > length' );
341		set S0, "abcdefghijk"
342		set S1, "xyz0123"
343		substr S2, S0, 4, 3, S1
344		print S0
345		print "\n"
346		print S1
347		print "\n"
348		print S2
349		print "\n"
350		end
351		CODE
352		abcdxyz0123hijk
353		xyz0123
354		efg
355		OUTPUT
	411	.sub five_arg_substr_w_replacement_lt_length
	412	set $S0, "abcdefghijk"
	413	set $S1, "x"
	414	substr $S2, $S0, 4, 3, $S1
	415	is( $S0, "abcdxhijk", '' )
	416	is( $S1, "x", '' )
	417	is( $S2, "efg", '' )
	418	.end
356	419
357		pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, replacement < length' );
358		set S0, "abcdefghijk"
359		set S1, "x"
360		substr S2, S0, 4, 3, S1
361		print S0
362		print "\n"
363		print S1
364		print "\n"
365		print S2
366		print "\n"
367		end
368		CODE
369		abcdxhijk
370		x
371		efg
372		OUTPUT
	420	.sub five_arg_substr__offset_at_end_of_string
	421	set $S0, "abcdefghijk"
	422	set $S1, "xyz"
	423	substr $S2, $S0, 11, 3, $S1
	424	is( $S0, "abcdefghijkxyz", '' )
	425	# print $S0
	426	# print "\n"
	427	is( $S1, "xyz", '' )
	428	# print $S1
	429	# print "\n"
	430	is( $S2, "", '' )
	431	# print $S2
	432	# print "\n"
	433	.end
373	434
374		pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, offset at end of string' );
375		set S0, "abcdefghijk"
376		set S1, "xyz"
377		substr S2, S0, 11, 3, S1
378		print S0
379		print "\n"
380		print S1
381		print "\n"
382		print S2
383		print "\n"
384		end
385		CODE
386		abcdefghijkxyz
387		xyz
	435	.sub exception_five_arg_substr__offset_past_end_of_string
	436	set $S0, "abcdefghijk"
	437	set $S1, "xyz"
	438	push_eh handler
	439	substr $S2, $S0, 12, 3, $S1
	440	ok(0,"no exception")
	441	handler:
	442	.exception_is( "Can only replace inside string or index after end of string" )
	443	.end
388	444
389		OUTPUT
	445	.sub five_arg_substr_neg_offset_repl_eq_length
	446	set $S0, "abcdefghijk"
	447	set $S1, "xyz"
	448	substr $S2, $S0, -3, 3, $S1
	449	is( $S0, "abcdefghxyz", '' )
	450	is( $S1, "xyz", '' )
	451	is( $S2, "ijk", '' )
	452	.end
390	453
391		pasm_error_output_like( <<'CODE', <<'OUTPUT', '5 arg substr, offset past end of string' );
392		set S0, "abcdefghijk"
393		set S1, "xyz"
394		substr S2, S0, 12, 3, S1
395		print S0
396		print "\n"
397		print S1
398		print "\n"
399		print S2
400		print "\n"
401		end
402		CODE
403		/^Can only replace inside string or index after end of string/
404		OUTPUT
	454	.sub five_arg_substr_neg_offset_repl_gt_length
	455	set $S0, "abcdefghijk"
	456	set $S1, "xyz"
	457	substr $S2, $S0, -6, 2, $S1
	458	is( $S0, "abcdexyzhijk", '' )
	459	is( $S1, "xyz", '' )
	460	is( $S2, "fg", '' )
	461	.end
405	462
406		pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, -ve offset, repl=length' );
407		set S0, "abcdefghijk"
408		set S1, "xyz"
409		substr S2, S0, -3, 3, S1
410		print S0
411		print "\n"
412		print S1
413		print "\n"
414		print S2
415		print "\n"
416		end
417		CODE
418		abcdefghxyz
419		xyz
420		ijk
421		OUTPUT
	463	.sub five_arg_substr_neg_offset_repl_lt_length
	464	set $S0, "abcdefghijk"
	465	set $S1, "xyz"
	466	substr $S2, $S0, -6, 4, $S1
	467	is( $S0, "abcdexyzjk", '' )
	468	is( $S1, "xyz", '' )
	469	is( $S2, "fghi", '' )
	470	.end
422	471
423		pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, -ve offset, repl>length' );
424		set S0, "abcdefghijk"
425		set S1, "xyz"
426		substr S2, S0, -6, 2, S1
427		print S0
428		print "\n"
429		print S1
430		print "\n"
431		print S2
432		print "\n"
433		end
434		CODE
435		abcdexyzhijk
436		xyz
437		fg
438		OUTPUT
	472	.sub exception_five_arg_substr_neg_offset_out_of_string
	473	set $S0, "abcdefghijk"
	474	set $S1, "xyz"
	475	push_eh handler
	476	substr $S2, $S0, -12, 4, $S1
	477	ok(0,"no exception")
	478	handler:
	479	.exception_is( "Can only replace inside string or index after end of string" )
	480	.end
439	481
440		pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, -ve offset, repl<length' );
441		set S0, "abcdefghijk"
442		set S1, "xyz"
443		substr S2, S0, -6, 4, S1
444		print S0
445		print "\n"
446		print S1
447		print "\n"
448		print S2
449		print "\n"
450		end
451		CODE
452		abcdexyzjk
453		xyz
454		fghi
455		OUTPUT
	482	.sub five_arg_substr_length_gt_strlen
	483	set $S0, "abcdefghijk"
	484	set $S1, "xyz"
	485	substr $S2, $S0, 3, 11, $S1
	486	is( $S0, "abcxyz", '' )
	487	is( $S1, "xyz", '' )
	488	is( $S2, "defghijk", '' )
	489	.end
456	490
457		pasm_error_output_like( <<'CODE', <<'OUTPUT', '5 arg substr, -ve offset out of string' );
458		set S0, "abcdefghijk"
459		set S1, "xyz"
460		substr S2, S0, -12, 4, S1
461		print S0
462		print "\n"
463		print S1
464		print "\n"
465		print S2
466		print "\n"
467		end
468		CODE
469		/^Can only replace inside string or index after end of string/
470		OUTPUT
	491	.sub five_arg_substr_length_gt_strlen_neg_offset
	492	set $S0, "abcdefghijk"
	493	set $S1, "xyz"
	494	substr $S2, $S0, -3, 11, $S1
	495	is( $S0, "abcdefghxyz", '' )
	496	is( $S1, "xyz", '' )
	497	is( $S2, "ijk", '' )
	498	.end
471	499
472		pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, length > strlen ' );
473		set S0, "abcdefghijk"
474		set S1, "xyz"
475		substr S2, S0, 3, 11, S1
476		print S0
477		print "\n"
478		print S1
479		print "\n"
480		print S2
481		print "\n"
482		end
483		CODE
484		abcxyz
485		xyz
486		defghijk
487		OUTPUT
	500	.sub four_arg_replacement_only_substr
	501	set $S0, "abcdefghijk"
	502	set $S1, "xyz"
	503	substr $S0, 3, 3, $S1
	504	is( $S0, "abcxyzghijk", '' )
	505	is( $S1, "xyz", '' )
	506	.end
488	507
489		pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, length > strlen, -ve offset' );
490		set S0, "abcdefghijk"
491		set S1, "xyz"
492		substr S2, S0, -3, 11, S1
493		print S0
494		print "\n"
495		print S1
496		print "\n"
497		print S2
498		print "\n"
499		end
500		CODE
501		abcdefghxyz
502		xyz
503		ijk
504		OUTPUT
	508	.sub three_arg_substr
	509	set $S0, "JAPH"
	510	substr $S1, $S0, 2
	511	is( $S1, "PH", '' )
	512	.end
505	513
506		pasm_output_is( <<'CODE', <<'OUTPUT', '4-arg, replacement-only substr' );
507		set S0, "abcdefghijk"
508		set S1, "xyz"
509		substr S0, 3, 3, S1
510		print S0
511		print "\n"
512		print S1
513		print "\n"
514		end
515		CODE
516		abcxyzghijk
517		xyz
518		OUTPUT
	514	.sub exception_substr__pos_offset_zero_length_string
	515	set $S0, ""
	516	push_eh handler
	517	substr $S1, $S0, 10, 3
	518	ok(0,"no exception")
	519	handler:
	520	.exception_is( "Cannot take substr outside string" )
	521	.end
519	522
520		pasm_output_is( <<'CODE', 'PH', '3-arg substr' );
521		set S0, "JAPH"
522		substr S1, S0, 2
523		print S1
524		end
525		CODE
	523	.sub substr_offset_zero_zero_length_string
	524	set $S0, ""
	525	substr $S1, $S0, 0, 1
	526	is( $S1, "", '' )
	527	.end
526	528
527		pasm_error_output_like( <<'CODE', <<'OUTPUT', "substr, +ve offset, zero-length string" );
528		~~set~~ S0, ""
529		~~substr S1, S0, 10, 3~~
530		~~print S~~1
531		~~end~~
532		CODE
533		/Cannot take substr outside string/
534		OUTPUT
	529	.sub exception_substr_offset_one_zero_length_string
	530	set $S0, ""
	531	push_eh handler
	532	substr $S1, $S0, -1, 1
	533	ok(0,"no exception")
	534	handler:
	535	.exception_is( "Cannot take substr outside string" )
	536	.end
535	537
536		pasm_output_is( <<'CODE', <<'OUTPUT', 'substr, offset 0, zero-length string' );
537		set S0, ""
538		substr S1, S0, 0, 1
539		print S1
540		print "_\n"
541		end
542		CODE
543		_
544		OUTPUT
	538	.sub exception_substr_neg_offset_zero_length_string
	539	set $S0, ""
	540	push_eh handler
	541	substr $S1, $S0, -10, 5
	542	handler:
	543	.exception_is( "Cannot take substr outside string" )
	544	.end
545	545
546		pasm_error_output_like( <<'CODE', <<'OUTPUT', "substr, offset -1, zero-length string" );
547		set S0, ""
548		substr S1, S0, -1, 1
549		print S1
550		end
551		CODE
552		/Cannot take substr outside string/
553		OUTPUT
	546	.sub zero_length_substr_zero_length_string
	547	set $S0, ""
	548	substr $S1, $S0, 10, 0
	549	is( $S1, "", '' )
	550	.end
554	551
555		pasm_error_output_like( <<'CODE', <<'OUTPUT', "substr, -ve offset, zero-length string" );
556		set S0, ""
557		substr S1, S0, -10, 5
558		print S1
559		end
560		CODE
561		/Cannot take substr outside string/
562		OUTPUT
	552	.sub zero_length_substr_zero_length_string
	553	set $S0, ""
	554	substr $S1, $S0, -10, 0
	555	is( $S1, "", '' )
	556	.end
563	557
564		pasm_output_is( <<'CODE', <<'OUTPUT', 'zero-length substr, zero-length string' );
565		set S0, ""
566		substr S1, S0, 10, 0
567		print S1
568		print "_\n"
569		end
570		CODE
571		_
572		OUTPUT
	558	.sub three_arg_substr_zero_length_string
	559	set $S0, ""
	560	substr $S1, $S0, 2
	561	is( $S1, "", '' )
	562	.end
573	563
574		pasm_output_is( <<'CODE', <<'OUTPUT', 'zero-length substr, zero-length string' );
575		set S0, ""
576		substr S1, S0, -10, 0
577		print S1
578		print "_\n"
579		end
580		CODE
581		_
582		OUTPUT
	564	.sub five_arg_substr_zero_length_string
	565	set $S0, ""
	566	set $S1, "xyz"
	567	substr $S2, $S0, 0, 3, $S1
	568	is( $S0, "xyz", '' )
	569	is( $S1, "xyz", '' )
	570	is( $S2, "", '' )
583	571
584		pasm_output_is( <<'CODE', <<'OUTPUT', '3-arg substr, zero-length string' );
585		set S0, ""
586		substr S1, S0, 2
587		print S1
588		print "_\n"
589		end
590		CODE
591		_
592		OUTPUT
	572	set $S3, ""
	573	set $S4, "abcde"
	574	substr $S5, $S3, 0, 0, $S4
	575	is( $S3, "abcde", '' )
	576	is( $S4, "abcde", '' )
	577	is( $S5, "", '' )
	578	.end
593	579
594		pasm_output_is( <<'CODE', <<'OUTPUT', '5 arg substr, zero-length string' );
595		set S0, ""
596		set S1, "xyz"
597		substr S2, S0, 0, 3, S1
598		print S0
599		print "\n"
600		print S1
601		print "\n"
602		print S2
603		print "\n"
	580	.sub four_arg_substr_replace_zero_length_string
	581	set $S0, ""
	582	set $S1, "xyz"
	583	substr $S0, 0, 3, $S1
	584	is( $S0, "xyz", '' )
	585	is( $S1, "xyz", '' )
604	586
605		set S3, ""
606		set S4, "abcde"
607		substr S5, S3, 0, 0, S4
608		print S3
609		print "\n"
610		print S4
611		print "\n"
612		print S5
613		print "\n"
614		end
615		CODE
616		xyz
617		xyz
	587	set $S2, ""
	588	set $S3, "abcde"
	589	substr $S2, 0, 0, $S3
	590	is( $S2, "abcde", '' )
	591	is( $S3, "abcde", '' )
	592	.end
618	593
619		abcde
620		abcde
	594	.sub concat_s_s_sc_null_onto_null
	595	concat $S0, $S0
	596	is( $S0, "", '' )
	597	concat $S1, ""
	598	is( $S1, "", '' )
	599	.end
621	600
622		OUTPUT
	601	.sub concat_s_sc_repeated_two_arg_concats
	602	set $S12, ""
	603	set $I0, 0
	604	WHILE:
	605	concat $S12, "hi"
	606	add $I0, 1
	607	lt $I0, 10, WHILE
	608	is( $S12, "hihihihihihihihihihi", '' )
	609	.end
623	610
624		pasm_output_is( <<'CODE', <<'OUTPUT', '4 arg substr replace, zero-length string' );
625		set S0, ""
626		set S1, "xyz"
627		substr S0, 0, 3, S1
628		print S0
629		print "\n"
630		print S1
631		print "\n"
	611	.sub concat_s_s_sc_foo_one_onto_null
	612	concat $S0, "foo1"
	613	set $S1, "foo2"
	614	concat $S2, $S1
	615	is( $S0, "foo1", '' )
	616	is( $S2, "foo2", '' )
	617	.end
632	618
633		set S2, ""
634		set S3, "abcde"
635		substr S2, 0, 0, S3
636		print S2
637		print "\n"
638		print S3
639		print "\n"
640		end
641		CODE
642		xyz
643		xyz
644		abcde
645		abcde
646		OUTPUT
	619	.sub test_concat_s_s_sc
	620	set $S1, "fish"
	621	set $S2, "bone"
	622	concat $S1, $S2
	623	is( $S1, "fishbone", '' )
	624	.end
647	625
648		pasm_output_is( <<'CODE', '<><', 'concat_s_s\|sc, null onto null' );
649		print "<>"
650		concat S0, S0
651		concat S1, ""
652		print "<"
653		end
654		CODE
	626	.sub concat_s_s_sc_s_sc
	627	set $S1, "japh"
	628	set $S2, "JAPH"
	629	concat $S0, "japh", "JAPH"
	630	is( $S0, "japhJAPH", '' )
655	631
656		pasm_output_is( <<'CODE', <<'OUTPUT', 'concat_s_sc, repeated two-arg concats' );
657		set S12, ""
658		set I0, 0
659		WHILE:
660		concat S12, "hi"
661		add I0, 1
662		lt I0, 10, WHILE
663		print S12
664		print "\n"
665		end
666		CODE
667		hihihihihihihihihihi
668		OUTPUT
	632	concat $S0, $S1, "JAPH"
	633	is( $S0, "japhJAPH", '' )
669	634
670		pasm_output_is( <<'CODE', <<'OUTPUT', 'concat_s_s\|sc, "foo1" onto null' );
671		concat S0, "foo1"
672		set S1, "foo2"
673		concat S2, S1
674		print S0
675		print "\n"
676		print S2
677		print "\n"
678		end
679		CODE
680		foo1
681		foo2
682		OUTPUT
	635	concat $S0, "japh", $S2
	636	is( $S0, "japhJAPH", '' )
683	637
684		pasm_output_is( <<'CODE', <<'OUTPUT', 'concat_s_s\|sc' );
685		set S1, "fish"
686		set S2, "bone"
687		concat S1, S2
688		print S1
689		concat S1, "\n"
690		print S1
691		end
692		CODE
693		fishbonefishbone
694		OUTPUT
	638	concat $S0, $S1, $S2
	639	is( $S0, "japhJAPH", '' )
	640	.end
695	641
696		pasm_output_is( <<'CODE', <<'OUTPUT', 'concat_s_s\|sc_s\|sc' );
697		set S1, "japh"
698		set S2, "JAPH"
699		concat S0, "japh", "JAPH"
700		print S0
701		print "\n"
702		concat S0, S1, "JAPH"
703		print S0
704		print "\n"
705		concat S0, "japh", S2
706		print S0
707		print "\n"
708		concat S0, S1, S2
709		print S0
710		print "\n"
711		end
712		CODE
713		japhJAPH
714		japhJAPH
715		japhJAPH
716		japhJAPH
717		OUTPUT
	642	.sub concat_ensure_copy_is_made
	643	set $S2, "JAPH"
	644	concat $S0, $S2, ""
	645	concat $S1, "", $S2
	646	chopn $S0, 1
	647	chopn $S1, 1
	648	is( $S2, "JAPH", '' )
	649	.end
718	650
719		pasm_output_is( <<'CODE', <<'OUTPUT', 'concat - ensure copy is made' );
720		set S2, "JAPH"
721		concat S0, S2, ""
722		concat S1, "", S2
723		chopn S0, 1
724		chopn S1, 1
725		print S2
726		print "\n"
727		end
728		CODE
729		JAPH
730		OUTPUT
731
732		pasm_output_is( <<"CODE", <<'OUTPUT', 'clears' );
733		@{[ set_str_regs( sub {"BOO $_[0]\\n"} ) ]}
	651	.sub test_clears
	652	set $S0, "BOO 0"
	653	set $S1, "BOO 1"
	654	set $S2, "BOO 2"
	655	set $S3, "BOO 3"
	656	set $S4, "BOO 4"
	657	set $S5, "BOO 5"
	658	set $S6, "BOO 6"
	659	set $S7, "BOO 7"
	660	set $S8, "BOO 8"
	661	set $S9, "BOO 9"
	662	set $S10, "BOO 10"
	663	set $S11, "BOO 11"
	664	set $S12, "BOO 12"
	665	set $S13, "BOO 13"
	666	set $S14, "BOO 14"
	667	set $S15, "BOO 15"
	668	set $S16, "BOO 16"
	669	set $S17, "BOO 17"
	670	set $S18, "BOO 18"
	671	set $S19, "BOO 19"
	672	set $S20, "BOO 20"
	673	set $S21, "BOO 21"
	674	set $S22, "BOO 22"
	675	set $S23, "BOO 23"
	676	set $S24, "BOO 24"
	677	set $S25, "BOO 25"
	678	set $S26, "BOO 26"
	679	set $S27, "BOO 27"
	680	set $S28, "BOO 28"
	681	set $S29, "BOO 29"
	682	set $S30, "BOO 30"
	683	set $S31, "BOO 31"
734	684	clears
735		@{[ print_str_regs() ]}
736		print "done\\n"
737		end
738		CODE
739		done
740		OUTPUT
	685	is( $S0, "", '' )
	686	is( $S1, "", '' )
	687	is( $S2, "", '' )
	688	is( $S3, "", '' )
	689	is( $S4, "", '' )
	690	is( $S5, "", '' )
	691	is( $S6, "", '' )
	692	is( $S7, "", '' )
	693	is( $S8, "", '' )
	694	is( $S9, "", '' )
	695	is( $S10, "", '' )
	696	is( $S11, "", '' )
	697	is( $S12, "", '' )
	698	is( $S13, "", '' )
	699	is( $S14, "", '' )
	700	is( $S15, "", '' )
	701	is( $S16, "", '' )
	702	is( $S17, "", '' )
	703	is( $S18, "", '' )
	704	is( $S19, "", '' )
	705	is( $S20, "", '' )
	706	is( $S21, "", '' )
	707	is( $S22, "", '' )
	708	is( $S23, "", '' )
	709	is( $S24, "", '' )
	710	is( $S25, "", '' )
	711	is( $S26, "", '' )
	712	is( $S27, "", '' )
	713	is( $S28, "", '' )
	714	is( $S29, "", '' )
	715	is( $S30, "", '' )
	716	is( $S31, "", '' )
	717	.end
741	718
742		my @strings = (
743		"hello", "hello", "hello", "world", "world", "hello", "hello", "hellooo",
744		"hellooo", "hello", "hello", "hella", "hella", "hello", "hella", "hellooo",
745		"hellooo", "hella", "hElLo", "HeLlO", "hElLo", "hElLo"
746		);
	719	.sub same_constant_twice_bug
	720	set $S0, ""
	721	set $S1, ""
	722	set $S2, "foo"
	723	concat $S1,$S1,$S2
	724	is( $S1, "foo", 'same constant twice bug' )
	725	is( $S0, "", 'same constant twice bug' )
	726	.end
747	727
748		pasm_output_is( <<"CODE", <<'OUTPUT', 'eq_s_s_ic' );
749		@{[ compare_strings( 0, "eq", @strings ) ]}
750		print "ok\\n"
751		end
752		ERROR:
753		print "bad\\n"
754		end
755		CODE
756		ok
757		OUTPUT
	728	.sub exception_two_param_ord_empty_string
	729	push_eh handler
	730	ord $I0,""
	731	ok(0, 'no exception: 2-param ord, empty string' )
	732	handler:
	733	.exception_is( 'Cannot get character of empty string' )
	734	.end
758	735
759		pasm_output_is( <<"CODE", <<'OUTPUT', 'eq_sc_s_ic' );
760		@{[ compare_strings( 1, "eq", @strings ) ]}
761		print "ok\\n"
762		end
763		ERROR:
764		print "bad\\n"
765		end
766		CODE
767		ok
768		OUTPUT
	736	.sub exception_two_param_ord_empty_string_register
	737	push_eh handler
	738	ord $I0,$S0
	739	ok( 0, 'no exception: 2-param ord, empty string register' )
	740	handler:
	741	.exception_is( 'Cannot get character of empty string' )
	742	.end
769	743
770		pasm_output_is( <<"CODE", <<'OUTPUT', 'eq_s_sc_ic' );
771		@{[ compare_strings( 2, "eq", @strings ) ]}
772		print "ok\\n"
773		end
774		ERROR:
775		print "bad\\n"
776		end
777		CODE
778		ok
779		OUTPUT
	744	.sub exception_three_param_ord_empty_string
	745	push_eh handler
	746	ord $I0,"",0
	747	ok(0, 'no exception: 3-param ord, empty string' )
	748	handler:
	749	.exception_is( 'Cannot get character of empty string' )
	750	.end
780	751
781		pasm_output_is( <<"CODE", <<'OUTPUT', 'eq_sc_sc_ic' );
782		@{[ compare_strings( 3, "eq", @strings ) ]}
783		print "ok\\n"
784		end
785		ERROR:
786		print "bad\\n"
787		end
788		CODE
789		ok
790		OUTPUT
	752	.sub exception_three_param_ord_empty_string_register
	753	push_eh handler
	754	ord $I0,$S0,0
	755	ok( 0, 'no exception: 3-param ord, empty string register' )
	756	handler:
	757	.exception_is( 'Cannot get character of empty string' )
	758	.end
791	759
792		pasm_output_is( <<"CODE", <<'OUTPUT', 'ne_s_s_ic' );
793		@{[ compare_strings( 0, "ne", @strings ) ]}
794		print "ok\\n"
795		end
796		ERROR:
797		print "bad\\n"
798		end
799		CODE
800		ok
801		OUTPUT
	760	.sub two_param_ord_one_character_string
	761	ord $I0,"a"
	762	is( $I0, "97", '2-param ord, one-character string' )
	763	.end
802	764
803		pasm_output_is( <<"CODE", <<'OUTPUT', 'ne_sc_s_ic' );
804		@{[ compare_strings( 1, "ne", @strings ) ]}
805		print "ok\\n"
806		end
807		ERROR:
808		print "bad\\n"
809		end
810		CODE
811		ok
812		OUTPUT
	765	.sub two_param_ord_multi_character_string
	766	ord $I0,"abc"
	767	is( $I0, "97", '2-param ord, multi-character string' )
	768	.end
813	769
814		pasm_output_is( <<"CODE", <<'OUTPUT', 'ne_s_sc_ic' );
815		@{[ compare_strings( 2, "ne", @strings ) ]}
816		print "ok\\n"
817		end
818		ERROR:
819		print "bad\\n"
820		end
821		CODE
822		ok
823		OUTPUT
	770	.sub two_param_ord_one_character_string_register
	771	set $S0,"a"
	772	ord $I0,$S0
	773	is( $I0, "97", '2-param ord, one-character string register' )
	774	.end
824	775
825		pasm_output_is( <<"CODE", <<'OUTPUT', 'ne_sc_sc_ic' );
826		@{[ compare_strings( 3, "ne", @strings ) ]}
827		print "ok\\n"
828		end
829		ERROR:
830		print "bad\\n"
831		end
832		CODE
833		ok
834		OUTPUT
	776	.sub three_param_ord_one_character_string
	777	ord $I0,"a",0
	778	is( $I0, "97", '3-param ord, one-character string' )
	779	.end
835	780
836		pasm_output_is( <<"CODE", <<'OUTPUT', 'lt_s_s_ic' );
837		@{[ compare_strings( 0, "lt", @strings ) ]}
838		print "ok\\n"
839		end
840		ERROR:
841		print "bad\\n"
842		end
843		CODE
844		ok
845		OUTPUT
	781	.sub three_param_ord_one_character_string_register
	782	set $S0,"a"
	783	ord $I0,$S0,0
	784	is( $I0, "97", '3-param ord, one-character string register' )
	785	.end
846	786
847		pasm_output_is( <<"CODE", <<'OUTPUT', 'lt_sc_s_ic' );
848		@{[ compare_strings( 1, "lt", @strings ) ]}
849		print "ok\\n"
850		end
851		ERROR:
852		print "bad\\n"
853		end
854		CODE
855		ok
856		OUTPUT
	787	.sub three_param_ord_multi_character_string
	788	ord $I0,"ab",1
	789	is( $I0, "98", '3-param ord, multi-character string' )
	790	.end
857	791
858		pasm_output_is( <<"CODE", <<'OUTPUT', 'lt_s_sc_ic' );
859		@{[ compare_strings( 2, "lt", @strings ) ]}
860		print "ok\\n"
861		end
862		ERROR:
863		print "bad\\n"
864		end
865		CODE
866		ok
867		OUTPUT
	792	.sub three_param_ord_multi_character_string_register
	793	set $S0,"ab"
	794	ord $I0,$S0,1
	795	is( $I0, "98", '3-param ord, multi-character string register' )
	796	.end
868	797
869		pasm_output_is( <<"CODE", <<'OUTPUT', 'lt_sc_sc_ic' );
870		@{[ compare_strings( 3, "lt", @strings ) ]}
871		print "ok\\n"
872		end
873		ERROR:
874		print "bad\\n"
875		end
876		CODE
877		ok
878		OUTPUT
	798	.sub exception_three_param_ord_multi_character_string
	799	push_eh handler
	800	ord $I0,"ab",2
	801	ok( 0, 'no exception: 3-param ord, multi-character string' )
	802	handler:
	803	.exception_is( 'Cannot get character past end of string' )
	804	.end
879	805
880		pasm_output_is( <<"CODE", <<'OUTPUT', 'le_s_s_ic' );
881		@{[ compare_strings( 0, "le", @strings ) ]}
882		print "ok\\n"
883		end
884		ERROR:
885		print "bad\\n"
886		end
887		CODE
888		ok
889		OUTPUT
	806	.sub exception_three_param_ord_multi_character_string
	807	push_eh handler
	808	set $S0,"ab"
	809	ord $I0,$S0,2
	810	ok( 0, 'no exception: 3-param ord, multi-character string' )
	811	handler:
	812	.exception_is( 'Cannot get character past end of string' )
	813	.end
890	814
891		pasm_output_is( <<"CODE", <<'OUTPUT', 'le_sc_s_ic' );
892		@{[ compare_strings( 1, "le", @strings ) ]}
893		print "ok\\n"
894		end
895		ERROR:
896		print "bad\\n"
897		end
898		CODE
899		ok
900		OUTPUT
	815	.sub three_param_ord_one_character_string_from_end
	816	ord $I0,"a",-1
	817	is( $I0, "97", '3-param ord, one-character string, from end' )
	818	.end
901	819
902		pasm_output_is( <<"CODE", <<'OUTPUT', 'le_s_sc_ic' );
903		@{[ compare_strings( 2, "le", @strings ) ]}
904		print "ok\\n"
905		end
906		ERROR:
907		print "bad\\n"
908		end
909		CODE
910		ok
911		OUTPUT
	820	.sub three_param_ord_one_character_string_register_from_end
	821	set $S0,"a"
	822	ord $I0,$S0,-1
	823	is( $I0, "97", '3-param ord, one-character string register, from end' )
	824	.end
912	825
913		pasm_output_is( <<"CODE", <<'OUTPUT', 'le_sc_sc_ic' );
914		@{[ compare_strings( 3, "le", @strings ) ]}
915		print "ok\\n"
916		end
917		ERROR:
918		print "bad\\n"
919		end
920		CODE
921		ok
922		OUTPUT
	826	.sub three_param_ord_multi_character_string_from_end
	827	ord $I0,"ab",-1
	828	is( $I0, "98", '3-param ord, multi-character string, from end' )
	829	.end
923	830
924		pasm_output_is( <<"CODE", <<'OUTPUT', 'gt_s_s_ic' );
925		@{[ compare_strings( 0, "gt", @strings ) ]}
926		print "ok\\n"
927		end
928		ERROR:
929		print "bad\\n"
930		end
931		CODE
932		ok
933		OUTPUT
	831	.sub three_param_ord_multi_character_string_register_from_end
	832	set $S0,"ab"
	833	ord $I0,$S0,-1
	834	is( $I0, "98", '3-param ord, multi-character string register, from end' )
	835	.end
934	836
935		pasm_output_is( <<"CODE", <<'OUTPUT', 'gt_sc_s_ic' );
936		@{[ compare_strings( 1, "gt", @strings ) ]}
937		print "ok\\n"
938		end
939		ERROR:
940		print "bad\\n"
941		end
942		CODE
943		ok
944		OUTPUT
	837	.sub exception_three_param_ord_multi_character_string_register_from_end_oob
	838	push_eh handler
	839	set $S0,"ab"
	840	ord $I0,$S0,-3
	841	ok( 0, 'no exception: 3-param ord, multi-character string register, from end, OOB' )
	842	handler:
	843	.exception_is( 'Cannot get character before beginning of string' )
	844	.end
945	845
946		pasm_output_is( <<"CODE", <<'OUTPUT', 'gt_s_sc_ic' );
947		@{[ compare_strings( 2, "gt", @strings ) ]}
948		print "ok\\n"
949		end
950		ERROR:
951		print "bad\\n"
952		end
953		CODE
954		ok
955		OUTPUT
	846	.sub chr_of_thirty_two_is_space_in_ascii
	847	chr $S0, 32
	848	is( $S0, " ", 'chr of 32 is space in ASCII' )
	849	.end
956	850
957		pasm_output_is( <<"CODE", <<'OUTPUT', 'gt_sc_sc_ic' );
958		@{[ compare_strings( 3, "gt", @strings ) ]}
959		print "ok\\n"
960		end
961		ERROR:
962		print "bad\\n"
963		end
964		CODE
965		ok
966		OUTPUT
	851	.sub chr_of_sixty_five_is_a_in_ascii
	852	chr $S0, 65
	853	is( $S0, "A", 'chr of 65 is A in ASCII' )
	854	.end
967	855
968		pasm_output_is( <<"CODE", <<'OUTPUT', 'ge_s_s_ic' );
969		@{[ compare_strings( 0, "ge", @strings ) ]}
970		print "ok\\n"
971		end
972		ERROR:
973		print "bad\\n"
974		end
975		CODE
976		ok
977		OUTPUT
	856	.sub chr_of_one_hundred_and_twenty_two_is_z_in_ascii
	857	chr $S0, 122
	858	is( $S0, "z", 'chr of 122 is z in ASCII' )
	859	.end
978	860
979		pasm_output_is( <<"CODE", <<'OUTPUT', 'ge_sc_s_ic' );
980		@{[ compare_strings( 1, "ge", @strings ) ]}
981		print "ok\\n"
982		end
983		ERROR:
984		print "bad\\n"
985		end
986		CODE
987		ok
988		OUTPUT
	861	.sub test_if_s_ic
	862	set $S0, "I've told you once, I've told you twice..."
	863	ok( $S0, 'normal strings are true' )
989	864
990		pasm_output_is( <<"CODE", <<'OUTPUT', 'ge_s_sc_ic' );
991		@{[ compare_strings( 2, "ge", @strings ) ]}
992		print "ok\\n"
993		end
994		ERROR:
995		print "bad\\n"
996		end
997		CODE
998		ok
999		OUTPUT
	865	set $S0, "0.0"
	866	ok( $S0, '0.0 is true' )
1000	867
1001		pasm_output_is( <<"CODE", <<'OUTPUT', 'ge_sc_sc_ic' );
1002		@{[ compare_strings( 3, "ge", @strings ) ]}
1003		print "ok\\n"
1004		end
1005		ERROR:
1006		print "bad\\n"
1007		end
1008		CODE
1009		ok
1010		OUTPUT
	868	set $S0, ""
	869	nok( $S0, 'empty string is false' )
1011	870
1012		pasm_output_is( <<'CODE', <<'OUTPUT', 'same constant twice bug' );
1013		set S0, ""
1014		set S1, ""
1015		set S2, "foo"
1016		concat S1,S1,S2
1017		print S1
1018		print S0
1019		print "\n"
1020		end
1021		CODE
1022		foo
1023		OUTPUT
	871	set $S0, "0"
	872	nok( $S0, '"0" string is false' )
1024	873
1025		pasm_error_output_like( <<'CODE', <<'OUTPUT', '2-param ord, empty string' );
1026		ord I0,""
1027		print I0
1028		end
1029		CODE
1030		/^Cannot get character of empty string/
1031		OUTPUT
	874	set $S0, "0e0"
	875	ok( $S0, 'string "0e0" is true' )
1032	876
1033		pasm_error_output_like( <<'CODE', <<'OUTPUT', '2-param ord, empty string register' );
1034		ord I0,S0
1035		print I0
1036		end
1037		CODE
1038		/^Cannot get character of empty string/
1039		OUTPUT
	877	set $S0, "x"
	878	ok( $S0, 'string "x" is true' )
1040	879
1041		pasm_error_output_like( <<'CODE', <<'OUTPUT', '3-param ord, empty string' );
1042		ord I0,"",0
1043		print I0
1044		end
1045		CODE
1046		/^Cannot get character of empty string/
1047		OUTPUT
	880	set $S0, "\\x0"
	881	ok( $S0, 'string "\\x0" is true' )
1048	882
1049		pasm_error_output_like( <<'CODE', <<'OUTPUT', '3-param ord, empty string register' );
1050		ord I0,S0,0
1051		print I0
1052		end
1053		CODE
1054		/^Cannot get character of empty string/
1055		OUTPUT
	883	set $S0, "\n"
	884	ok( $S0, 'string "\n" is true' )
1056	885
1057		pasm_output_is( <<'CODE', ord('a'), '2-param ord, one-character string' );
1058		ord I0,"a"
1059		print I0
1060		end
1061		CODE
	886	set $S0, " "
	887	ok( $S0, 'string " " is true' )
1062	888
1063		pasm_output_is( <<'CODE', ord('a'), '2-param ord, multi-character string' );
1064		ord I0,"abc"
1065		print I0
1066		end
1067		CODE
	889	# An empty register should be false...
	890	clears
	891	nok( $S1, 'empty register is false' )
	892	.end
1068	893
1069		pasm_output_is( <<'CODE', ord('a'), '2-param ord, one-character string register' );
1070		set S0,"a"
1071		ord I0,S0
1072		print I0
1073		end
1074		CODE
	894	.sub repeat_s_s_sc_i_ic
	895	set $S0, "x"
	896	repeat $S1, $S0, 12
	897	is( $S0, "x", 'repeat_s_s\|sc_i\|ic' )
	898	is( $S1, "xxxxxxxxxxxx", 'repeat_s_s\|sc_i\|ic' )
	899
	900	set $I0, 12
	901	set $S2, "X"
	902	repeat $S3, $S2, $I0
	903	is( $S2, "X", 'repeat_s_s\|sc_i\|ic' )
	904	is( $S3, "XXXXXXXXXXXX", 'repeat_s_s\|sc_i\|ic' )
	905
	906	repeat $S4, "~", 12
	907	is( $S4, "~~~~~~~~~~~~", 'repeat_s_s\|sc_i\|ic' )
	908
	909	repeat $S5, "~", $I0
	910	is( $S5, "~~~~~~~~~~~~", 'repeat_s_s\|sc_i\|ic' )
	911
	912
	913	repeat $S6, "***", 0
	914	is( $S6, "", 'repeat_s_s\|sc_i\|ic' )
	915	.end
1075	916
1076		pasm_output_is( <<'CODE', ord('a'), '3-param ord, one-character string' );
1077		ord I0,"a",0
1078		print I0
1079		end
1080		CODE
	917	.sub exception_repeat_oob
	918	push_eh handler
	919	repeat $S0, "japh", -1
	920	handler:
	921	.exception_is( 'Cannot repeat with negative arg' )
	922	.end
1081	923
1082		pasm_output_is( <<'CODE', ord('a'), '3-param ord, one-character string register' );
1083		set S0,"a"
1084		ord I0,S0,0
1085		print I0
1086		end
1087		CODE
1088
1089		pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string' );
1090		ord I0,"ab",1
1091		print I0
1092		end
1093		CODE
1094
1095		pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string register' );
1096		set S0,"ab"
1097		ord I0,S0,1
1098		print I0
1099		end
1100		CODE
1101
1102		pasm_error_output_like( <<'CODE', <<'OUTPUT', '3-param ord, multi-character string' );
1103		ord I0,"ab",2
1104		print I0
1105		end
1106		CODE
1107		/^Cannot get character past end of string/
1108		OUTPUT
1109
1110		pasm_error_output_like( <<'CODE', <<'OUTPUT', '3-param ord, multi-character string' );
1111		set S0,"ab"
1112		ord I0,S0,2
1113		print I0
1114		end
1115		CODE
1116		/^Cannot get character past end of string/
1117		OUTPUT
1118
1119		pasm_output_is( <<'CODE', ord('a'), '3-param ord, one-character string, from end' );
1120		ord I0,"a",-1
1121		print I0
1122		end
1123		CODE
1124
1125		pasm_output_is( <<'CODE', ord('a'), '3-param ord, one-character string register, from end' );
1126		set S0,"a"
1127		ord I0,S0,-1
1128		print I0
1129		end
1130		CODE
1131
1132		pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string, from end' );
1133		ord I0,"ab",-1
1134		print I0
1135		end
1136		CODE
1137
1138		pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string register, from end' );
1139		set S0,"ab"
1140		ord I0,S0,-1
1141		print I0
1142		end
1143		CODE
1144
1145		pasm_error_output_like(
1146		<<'CODE', <<'OUTPUT', '3-param ord, multi-character string register, from end, OOB' );
1147		set S0,"ab"
1148		ord I0,S0,-3
1149		print I0
1150		end
1151		CODE
1152		/^Cannot get character before beginning of string/
1153		OUTPUT
1154
1155		pasm_output_is( <<'CODE', chr(32), 'chr of 32 is space in ASCII' );
1156		chr S0, 32
1157		print S0
1158		end
1159		CODE
1160
1161		pasm_output_is( <<'CODE', chr(65), 'chr of 65 is A in ASCII' );
1162		chr S0, 65
1163		print S0
1164		end
1165		CODE
1166
1167		pasm_output_is( <<'CODE', chr(122), 'chr of 122 is z in ASCII' );
1168		chr S0, 122
1169		print S0
1170		end
1171		CODE
1172
1173		pasm_output_is( <<'CODE', <<'OUTPUT', 'if_s_ic' );
1174		set S0, "I've told you once, I've told you twice..."
1175		if S0, OK1
1176		print "not "
1177		OK1: print "ok 1\n"
1178
1179		set S0, "0.0"
1180		if S0, OK2
1181		print "not "
1182		OK2: print "ok 2\n"
1183
1184		set S0, ""
1185		if S0, BAD3
1186		branch OK3
1187		BAD3: print "not "
1188		OK3: print "ok 3\n"
1189
1190		set S0, "0"
1191		if S0, BAD4
1192		branch OK4
1193		BAD4: print "not "
1194		OK4: print "ok 4\n"
1195
1196		set S0, "0e0"
1197		if S0, OK5
1198		print "not "
1199		OK5: print "ok 5\n"
1200
1201		set S0, "x"
1202		if S0, OK6
1203		print "not "
1204		OK6: print "ok 6\n"
1205
1206		set S0, "\\x0"
1207		if S0, OK7
1208		print "not "
1209		OK7: print "ok 7\n"
1210
1211		set S0, "\n"
1212		if S0, OK8
1213		print "not "
1214		OK8: print "ok 8\n"
1215
1216		set S0, " "
1217		if S0, OK9
1218		print "not "
1219		OK9: print "ok 9\n"
1220
1221		# An empty register should be false...
1222		clears
1223		if S1, BAD10
1224		branch OK10
1225		BAD10: print "not "
1226		OK10: print "ok 10\n"
1227
1228		end
1229		CODE
1230		ok 1
1231		ok 2
1232		ok 3
1233		ok 4
1234		ok 5
1235		ok 6
1236		ok 7
1237		ok 8
1238		ok 9
1239		ok 10
1240		OUTPUT
1241
1242		pasm_output_is( <<'CODE', <<'OUTPUT', 'repeat_s_s\|sc_i\|ic' );
1243		set S0, "x"
1244
1245		repeat S1, S0, 12
1246		print S0
1247		print "\n"
1248		print S1
1249		print "\n"
1250
1251		set I0, 12
1252		set S2, "X"
1253
1254		repeat S3, S2, I0
1255		print S2
1256		print "\n"
1257		print S3
1258		print "\n"
1259
1260		repeat S4, "~", 12
1261		print S4
1262		print "\n"
1263
1264		repeat S5, "~", I0
1265		print S5
1266		print "\n"
1267
1268		print ">"
1269		repeat S6, "***", 0
1270		print S6
1271		print "< done\n"
1272
1273		end
1274		CODE
1275		x
1276		xxxxxxxxxxxx
1277		X
1278		XXXXXXXXXXXX
1279		~~~~~~~~~~~~
1280		~~~~~~~~~~~~
1281		>< done
1282		OUTPUT
1283
1284		pasm_error_output_like( <<'CODE', qr/Cannot repeat with negative arg\n/, 'repeat OOB' );
1285		repeat S0, "japh", -1
1286		end
1287		CODE
1288
1289		pir_error_output_like( <<'CODE', qr/Cannot repeat with negative arg\n/, 'repeat OOB, repeat_p_p_p' );
1290		.sub main
	924	.sub exception_repeat_oob_repeat_p_p_p
	925	push_eh handler
1291	926	$P0 = new ['String']
1292	927	$P1 = new ['String']
1293	928	$P2 = new ['Integer']
1294
1295	929	$P2 = -1
1296
1297	930	repeat $P1, $P0, $P2
	931	handler:
	932	.exception_is( 'Cannot repeat with negative arg' )
1298	933	.end
1299		~~CODE~~
1300	934
1301		pir_error_output_like( <<'CODE', qr/Cannot repeat with negative arg\n/, 'repeat OOB, repeate_p_p_i' );
1302		.sub main
	935	.sub exception_repeat_oob_repeate_p_p_i
	936	push_eh handler
1303	937	$P0 = new ['String']
1304	938	$P1 = new ['String']
1305
1306	939	repeat $P1, $P0, -1
	940	handler:
	941	.exception_is( 'Cannot repeat with negative arg' )
1307	942	.end
1308		~~CODE~~
1309	943
1310		pir_output_is( <<'CODE', <<'OUTPUT', 'encodingname OOB' );
1311		.sub main
	944	.sub encodingname_oob
1312	945	$I0 = -1
1313
1314	946	$S0 = encodingname -1
1315	947	$S0 = encodingname $I0
1316		~~say 'ok'~~
	948	ok( 1, "no exceptions in encodingname_oob" )
1317	949	.end
1318		~~CODE~~
1319		ok
1320		~~OUTPUT~~
1321	950
1322		pasm_output_is( <<'CODE', <<'OUTPUT', 'index, 3-arg form' );
1323		set S0, "Parrot"
1324		set S1, "Par"
1325		index I1, S0, S1
1326		print I1
1327		print "\n"
	951	.sub index_three_arg_form
	952	set $S0, "Parrot"
	953	set $S1, "Par"
	954	index $I1, $S0, $S1
	955	is( $I1, "0", 'index, 3-arg form' )
1328	956
1329		set S1, "rot"
1330		index I1, S0, S1
1331		print I1
1332		print "\n"
	957	set $S1, "rot"
	958	index $I1, $S0, $S1
	959	is( $I1, "3", 'index, 3-arg form' )
	960
	961	set $S1, "bar"
	962	index $I1, $S0, $S1
	963	is( $I1, "-1", 'index, 3-arg form' )
	964	.end
1333	965
1334		set S1, "bar"
1335		index I1, S0, S1
1336		print I1
1337		print "\n"
	966	.sub index_four_arg_form
	967	set $S0, "Barbarian"
	968	set $S1, "ar"
	969	index $I1, $S0, $S1, 0
	970	is( $I1, "1", 'index, 4-arg form' )
	971
	972	index $I1, $S0, $S1, 2
	973	is( $I1, "4", 'index, 4-arg form' )
	974
	975	set $S1, "qwx"
	976	index $I1, $S0, $S1, 0
	977	is( $I1, "-1", 'index, 4-arg form' )
	978	.end
1338	979
1339		end
1340		CODE
1341		0
1342		3
1343		-1
1344		OUTPUT
	980	.sub index_four_arg_form_bug_twenty_two_thousand_seven_hundred_and_eighteen
	981	set $S1, "This is not quite right"
	982	set $S0, " is "
	983	index $I0, $S1, $S0, 0
	984	is( $I0, "4", 'index, 4-arg form, bug 22718' )
	985
	986	set $S0, "is"
	987	index $I0, $S1, $S0, 0
	988	is( $I0, "2", 'index, 4-arg form, bug 22718' )
	989	.end
1345	990
1346		pasm_output_is( <<'CODE', <<'OUTPUT', 'index, 4-arg form' );
1347		set S0, "Barbarian"
1348		set S1, "ar"
1349		index I1, S0, S1, 0
1350		print I1
1351		print "\n"
	991	.sub index_null_strings
	992	set $S0, "Parrot"
	993	set $S1, ""
	994	index $I1, $S0, $S1
	995	is( $I1, "-1", 'index, null strings' )
	996
	997	index $I1, $S0, $S1, 0
	998	is( $I1, "-1", 'index, null strings' )
	999
	1000	index $I1, $S0, $S1, 5
	1001	is( $I1, "-1", 'index, null strings' )
	1002
	1003	index $I1, $S0, $S1, 6
	1004	is( $I1, "-1", 'index, null strings' )
	1005
	1006	set $S0, ""
	1007	set $S1, "a"
	1008	index $I1, $S0, $S1
	1009	is( $I1, "-1", 'index, null strings' )
	1010
	1011	index $I1, $S0, $S1, 0
	1012	is( $I1, "-1", 'index, null strings' )
	1013
	1014	set $S0, "Parrot"
	1015	null $S1
	1016	index $I1, $S0, $S1
	1017	is( $I1, "-1", 'index, null strings' )
	1018
	1019	null $S0
	1020	null $S1
	1021	index $I1, $S0, $S1
	1022	is( $I1, "-1", 'index, null strings' )
	1023	.end
1352	1024
1353		index I1, S0, S1, 2
1354		print I1
1355		print "\n"
	1025	.sub index_embedded_nulls
	1026	set $S0, "Par\0\0rot"
	1027	set $S1, "\0"
	1028	index $I1, $S0, $S1
	1029	is( $I1, "3", 'index, embedded nulls' )
	1030
	1031	index $I1, $S0, $S1, 4
	1032	is( $I1, "4", 'index, embedded nulls' )
	1033	.end
1356	1034
1357		set S1, "qwx"
1358		index I1, S0, S1, 0
1359		print I1
1360		print "\n"
	1035	.sub index_big_strings
	1036	set $S0, "a"
	1037	repeat $S0, $S0, 10000
	1038	set $S1, "a"
	1039	repeat $S1, $S1, 500
	1040	index $I1, $S0, $S1
	1041	is( $I1, "0", 'index, big strings' )
	1042
	1043	index $I1, $S0, $S1, 1234
	1044	is( $I1, "1234", 'index, big strings' )
	1045
	1046	index $I1, $S0, $S1, 9501
	1047	is( $I1, "-1", 'index, big strings' )
	1048	.end
1361	1049
1362		~~end~~
1363		~~CODE~~
1364		1
1365		4
1366		-1
1367		~~OUTPUT~~
1368
1369		~~pasm_output_is( <<'CODE', <<'OUTPUT', 'index, 4-arg form, bug 22718' );~~
1370		~~set S1, "This is not quite right"~~
1371		~~set S0, " is "~~
1372		~~index I0, S1, S0, 0~~
1373		~~print I0~~
1374		~~set S0, "is"~~
1375		~~index I0, S1, S0, 0~~
1376		~~print I0~~
1377		~~print "\n"~~
1378		~~end~~
1379		~~CODE~~
1380		42
1381		~~OUTPUT~~
1382
1383		~~pasm_output_is( <<'CODE', <<'OUTPUT', 'index, null strings' );~~
1384		~~set S0, "Parrot"~~
1385		~~set S1, ""~~
1386		~~index I1, S0, S1~~
1387		~~print I1~~
1388		~~print "\n"~~
1389
1390		~~index I1, S0, S1, 0~~
1391		~~print I1~~
1392		~~print "\n"~~
1393
1394		~~index I1, S0, S1, 5~~
1395		~~print I1~~
1396		~~print "\n"~~
1397
1398		~~index I1, S0, S1, 6~~
1399		~~print I1~~
1400		~~print "\n"~~
1401
1402		~~set S0, ""~~
1403		~~set S1, "a"~~
1404		~~index I1, S0, S1~~
1405		~~print I1~~
1406		~~print "\n"~~
1407
1408		~~index I1, S0, S1, 0~~
1409		~~print I1~~
1410		~~print "\n"~~
1411
1412		~~set S0, "Parrot"~~
1413		~~null S1~~
1414		~~index I1, S0, S1~~
1415		~~print I1~~
1416		~~print "\n"~~
1417
1418		~~null S0~~
1419		~~null S1~~
1420		~~index I1, S0, S1~~
1421		~~print I1~~
1422		~~print "\n"~~
1423		~~end~~
1424		~~CODE~~
1425		-1
1426		-1
1427		-1
1428		-1
1429		-1
1430		-1
1431		-1
1432		-1
1433		~~OUTPUT~~
1434
1435		~~pasm_output_is( <<'CODE', <<'OUTPUT', 'index, embedded nulls' );~~
1436		~~set S0, "Par\0\0rot"~~
1437		~~set S1, "\0"~~
1438		~~index I1, S0, S1~~
1439		~~print I1~~
1440		~~print "\n"~~
1441
1442		~~index I1, S0, S1, 4~~
1443		~~print I1~~
1444		~~print "\n"~~
1445
1446		~~end~~
1447		~~CODE~~
1448		3
1449		4
1450		~~OUTPUT~~
1451
1452		~~pasm_output_is( <<'CODE', <<'OUTPUT', 'index, big strings' );~~
1453		~~set S0, "a"~~
1454		~~repeat S0, S0, 10000~~
1455		~~set S1, "a"~~
1456		~~repeat S1, S1, 500~~
1457		~~index I1, S0, S1~~
1458		~~print I1~~
1459		~~print "\n"~~
1460
1461		~~index I1, S0, S1, 1234~~
1462		~~print I1~~
1463		~~print "\n"~~
1464
1465		~~index I1, S0, S1, 9501~~
1466		~~print I1~~
1467		~~print "\n"~~
1468
1469		~~end~~
1470		~~CODE~~
1471		0
1472		~~1234~~
1473		-1
1474		~~OUTPUT~~
1475
1476		~~pasm_output_is( <<'CODE', <<'OUTPUT', 'index, big, hard to match strings' );~~
1477	1050	# Builds a 24th iteration fibonacci string (approx. 100K)
1478		set S1, "a"
1479		set S2, "b"
1480		set I0, 0
1481		LOOP:
1482		set S3, S1
1483		concat S1, S2, S3
1484		set S2, S3
1485		inc I0
1486		lt I0, 24, LOOP
	1051	.sub index_big_hard_to_match_strings
	1052	set $S1, "a"
	1053	set $S2, "b"
	1054	set $I0, 0
	1055	LOOP:
	1056	set $S3, $S1
	1057	concat $S1, $S2, $S3
	1058	set $S2, $S3
	1059	inc $I0
	1060	lt $I0, 24, LOOP
	1061	index $I1, $S1, $S2
	1062	is( $I1, "46368", 'index, big, hard to match strings' )
	1063	index $I1, $S1, $S2, 50000
	1064	is( $I1, "-1", 'index, big, hard to match strings' )
	1065	.end
1487	1066
1488		index I1, S1, S2
1489		print I1
1490		print "\n"
1491
1492		index I1, S1, S2, 50000
1493		print I1
1494		print "\n"
1495		end
1496		CODE
1497		46368
1498		-1
1499		OUTPUT
1500
1501		pir_output_is( << 'CODE', << 'OUTPUT', 'index with different charsets' );
1502
1503		.sub test :main
1504
1505		print "default - default:\n"
	1067	.sub index_with_different_charsets
1506	1068	set $S0, "Parrot"
1507	1069	set $S1, "rot"
1508	1070	index $I1, $S0, $S1
1509		print $I1
1510		print "\n"
	1071	is( $I1, "3", 'default - default' )
1511	1072
1512		~~print "ascii - ascii:\n"~~
1513	1073	set $S0, ascii:"Parrot"
1514	1074	set $S1, ascii:"rot"
1515	1075	index $I1, $S0, $S1
1516		print $I1
1517		print "\n"
	1076	is( $I1, "3", 'ascii - ascii')
1518	1077
1519		~~print "default - ascii:\n"~~
1520	1078	set $S0, "Parrot"
1521	1079	set $S1, ascii:"rot"
1522	1080	index $I1, $S0, $S1
1523		print $I1
1524		print "\n"
	1081	is( $I1, "3", 'default - ascii' )
1525	1082
1526		~~print "ascii - default:\n"~~
1527	1083	set $S0, ascii:"Parrot"
1528	1084	set $S1, "rot"
1529	1085	index $I1, $S0, $S1
1530		print $I1
1531		print "\n"
	1086	is( $I1, "3", 'ascii - default' )
1532	1087
1533		~~print "binary - binary:\n"~~
1534	1088	set $S0, binary:"Parrot"
1535	1089	set $S1, binary:"rot"
1536	1090	index $I1, $S0, $S1
1537		print $I1
1538		print "\n"
1539
	1091	is( $I1, "-1", 'binary - binary' )
1540	1092	.end
1541		~~CODE~~
1542		~~default - default:~~
1543		3
1544		~~ascii - ascii:~~
1545		3
1546		~~default - ascii:~~
1547		3
1548		~~ascii - default:~~
1549		3
1550		~~binary - binary:~~
1551		-1
1552		~~OUTPUT~~
1553	1093
1554		pasm_output_is( <<'CODE', <<'OUTPUT', 'negative index #35959' );
1555		index I1, "u", "t", -123456
1556		print I1
1557		print "\n"
1558		index I1, "u", "t", -123456789
1559		print I1
1560		print "\n"
1561		end
1562		CODE
1563		-1
1564		-1
1565		OUTPUT
	1094	.sub negative_index_bug_35959
	1095	index $I1, "u", "t", -123456
	1096	is( $I1, "-1", 'negative index #35959' )
1566	1097
1567		SKIP: {
1568		skip( "Pending rework of creating non-ascii literals", 2 );
1569		pasm_output_is( <<'CODE', <<'OUTPUT', 'index, multibyte matching' );
1570		set S0, "\xAB"
1571		find_chartype I0, "8859-1"
1572		set_chartype S0, I0
1573		find_encoding I0, "singlebyte"
1574		set_encoding S0, I0
	1098	index $I1, "u", "t", -123456789
	1099	is( $I1, "-1", 'negative index #35959' )
	1100	.end
1575	1101
1576		find_encoding I0, "utf8"
1577		find_chartype I1, "unicode"
1578		transcode S1, S0, I0, I1
	1102	.sub index_multibyte_matching
	1103	skip( 3, "Pending rework of creating non-ascii literals" )
1579	1104
1580		eq S0, S1, equal
1581		print "not "
1582		equal:
1583		print "equal\n"
	1105	# set $S0, "\xAB"
	1106	# find_chartype $I0, "8859-1"
	1107	# set_chartype $S0, $I0
	1108	# find_encoding $I0, "singlebyte"
	1109	# set_encoding $S0, $I0
	1110	# find_encoding $I0, "utf8"
	1111	# find_chartype $I1, "unicode"
	1112	# transcode $S1, $S0, $I0, $I1
	1113	# is( $S0, $S1, 'equal' );
1584	1114
1585		index I0, S0, S1
1586		print I0
1587		print "\n"
1588		index I0, S1, S0
1589		print I0
1590		print "\n"
1591		end
1592		CODE
1593		equal
1594		0
1595		0
1596		OUTPUT
	1115	# index $I0, $S0, $S1
	1116	# is( $I0, "0", 'index, multibyte matching' )
1597	1117
1598		pasm_output_is( <<'CODE', <<'OUTPUT', 'index, multibyte matching 2' );
1599		set S0, "\xAB\xBA"
1600		set S1, "foo\xAB\xAB\xBAbar"
1601		find_chartype I0, "8859-1"
1602		set_chartype S0, I0
1603		find_encoding I0, "singlebyte"
1604		set_encoding S0, I0
	1118	# index $I0, $S1, $S0
	1119	# is( $I0, "0", 'index, multibyte matching' )
	1120	.end
1605	1121
1606		find_chartype I0, "unicode"
1607		find_encoding I1, "utf8"
1608		transcode S1, S1, I1, I0
	1122	.sub index_multibyte_matching_two
	1123	skip( 2, "Pending rework of creating non-ascii literals" )
	1124	# set $S0, "\xAB\xBA"
	1125	# set $S1, "foo\xAB\xAB\xBAbar"
	1126	# find_chartype $I0, "8859-1"
	1127	# set_chartype $S0, $I0
	1128	# find_encoding $I0, "singlebyte"
	1129	# set_encoding $S0, $I0
	1130	# find_chartype $I0, "unicode"
	1131	# find_encoding $I1, "utf8"
	1132	# transcode $S1, $S1, $I1, $I0
	1133	# index $I0, $S0, $S1
	1134	# is( $I0, "-1", 'index, multibyte matching 2' )
	1135	# index $I0, $S1, $S0
	1136	# is( $I0, "4", 'index, multibyte matching 2' )
	1137	.end
1609	1138
1610		index I0, S0, S1
1611		print I0
1612		print "\n"
1613		index I0, S1, S0
1614		print I0
1615		print "\n"
1616		end
1617		CODE
1618		-1
1619		4
1620		OUTPUT
1621		}
	1139	.sub num_to_string
	1140	set $N0, 80.43
	1141	set $S0, $N0
	1142	is( $S0, "80.43", 'num to string' )
1622	1143
1623		pasm_output_is( <<'CODE', <<'OUTPUT', 'num to string' );
1624		set N0, 80.43
1625		set S0, N0
1626		print S0
1627		print "\n"
	1144	set $N0, -1.111111
	1145	set $S0, $N0
	1146	is( $S0, "-1.111111", 'num to string' )
	1147	.end
1628	1148
1629		set N0, -1.111111
1630		set S0, N0
1631		print S0
1632		print "\n"
1633		end
1634		CODE
1635		80.43
1636		-1.111111
1637		OUTPUT
	1149	.sub string_to_int
	1150	set $S0, "123"
	1151	set $I0, $S0
	1152	is( $I0, "123", 'string to int' )
1638	1153
1639		pasm_output_is( <<'CODE', <<'OUTPUT', 'string to int' );
1640		set S0, "123"
1641		set I0, S0
1642		print I0
1643		print "\n"
	1154	set $S0, " 1"
	1155	set $I0, $S0
	1156	is( $I0, "1", 'string to int' )
	1157
	1158	set $S0, "-1"
	1159	set $I0, $S0
	1160	is( $I0, "-1", 'string to int' )
	1161
	1162	set $S0, "Not a number"
	1163	set $I0, $S0
	1164	is( $I0, "0", 'string to int' )
	1165
	1166	set $S0, ""
	1167	set $I0, $S0
	1168	is( $I0, "0", 'string to int' )
	1169	.end
1644	1170
1645		set S0, " 1"
1646		set I0, S0
1647		print I0
1648		print "\n"
	1171	.sub concat_or_substr_cow
	1172	set $S0, "<JA"
	1173	set $S1, "PH>"
	1174	set $S2, ""
	1175	concat $S2, $S2, $S0
	1176	concat $S2, $S2, $S1
	1177	is( $S2, "<JAPH>", 'concat/substr (COW)' )
	1178
	1179	substr $S0, $S2, 1, 4
	1180	is( $S0, "JAPH", 'concat/substr (COW)' )
	1181	.end
1649	1182
1650		set S0, "-1"
1651		s~~et I0, S0~~
1652		~~print I0~~
1653		~~print "\n"~~
	1183	.sub constant_to_cstring
	1184	stringinfo $I0, "\n", 2
	1185	stringinfo $I1, "\n", 2
	1186	is( $I1, $I0, 'constant to cstring' )
1654	1187
1655		set S0, "Not a number"
1656		set I0, S0
1657		print I0
1658		print "\n"
	1188	stringinfo $I2, "\n", 2
	1189	is( $I2, $I0, 'constant to cstring' )
	1190	.end
1659	1191
1660		set S0, ""
1661		set I0, S0
1662		print I0
1663		print "\n"
	1192	.sub cow_with_chopn_leaving_original_untouched
	1193	set $S0, "ABCD"
	1194	clone $S1, $S0
	1195	chopn $S0, 1
	1196	is( $S0, "ABC", 'COW with chopn leaving original untouched' )
	1197	is( $S1, "ABCD", 'COW with chopn leaving original untouched' )
	1198	.end
1664	1199
1665		end
1666		CODE
1667		123
1668		1
1669		-1
1670		0
1671		0
1672		OUTPUT
	1200	.sub check_that_bug_bug_16874_was_fixed
	1201	set $S0, "foo "
	1202	set $S1, "bar "
	1203	set $S2, "quux "
	1204	set $S15, ""
	1205	concat $S15, $S0
	1206	concat $S15, $S1
	1207	concat $S15, $S2
	1208	is( $S15, "foo bar quux ", 'Check that bug #16874 was fixed' )
	1209	.end
1673	1210
1674		pasm_output_is( <<'CODE', <<'OUTPUT', 'concat/substr (COW)' );
1675		set S0, "<JA"
1676		set S1, "PH>"
1677		set S2, ""
1678		concat S2, S2, S0
1679		concat S2, S2, S1
1680		print S2
1681		print "\n"
1682		substr S0, S2, 1, 4
1683		print S0
1684		print "\n"
	1211	.sub stress_concat
	1212	set $I0, 1000
	1213	set $S0, "michael"
	1214	LOOP:
	1215	set $S2, $I0
	1216	concat $S1, $S0, $S2
	1217	concat $S3, "mic", "hael"
	1218	concat $S3, $S3, $S2
	1219	eq $S1, $S3, BOTTOM
	1220	ok(0, 'failed stress concat test')
1685	1221	end
1686		~~CODE~~
1687		~~<JAPH>~~
1688		~~JAPH~~
1689		~~OUTPUT~~
1690	1222
1691		pasm_output_is( <<'CODE', <<'OUTPUT', 'constant to cstring' );
1692		stringinfo I0, "\n", 2
1693		stringinfo I1, "\n", 2
1694		eq I1, I0, ok1
1695		print "N"
1696		ok1:
1697		print "OK"
1698		print "\n"
1699		stringinfo I2, "\n", 2
1700		eq I2, I0, ok2
1701		print "N"
1702		ok2:
1703		print "OK\n"
1704		end
1705		CODE
1706		OK
1707		OK
1708		OUTPUT
	1223	BOTTOM:
	1224	sub $I0, $I0, 1
	1225	ne $I0, 0, LOOP
	1226	ok(1, 'stress concat test')
	1227	.end
1709	1228
1710		pasm_output_is( <<'CODE', <<'OUTPUT', 'COW with chopn leaving original untouched' );
1711		set S0, "ABCD"
1712		clone S1, S0
1713		chopn S0, 1
1714		print S0
1715		print "\n"
1716		print S1
1717		print "\n"
1718		end
1719		CODE
1720		ABC
1721		ABCD
1722		OUTPUT
	1229	.sub ord_and_substring_see_bug_17035
	1230	set $S0, "abcdef"
	1231	substr $S1, $S0, 2, 3
	1232	ord $I0, $S0, 2
	1233	ord $I1, $S1, 0
	1234	ne $I0, $I1, fail
	1235	ord $I0, $S0, 3
	1236	ord $I1, $S1, 1
	1237	ne $I0, $I1, fail
	1238	ord $I0, $S0, 4
	1239	ord $I1, $S1, 2
	1240	ne $I0, $I1, fail
	1241	ok(1, 'ord and substring #17035')
	1242	goto end
	1243	fail:
	1244	ok(0, 'failed: ord and substring #17035')
	1245	end:
	1246	.end
1723	1247
1724		pasm_output_is( <<'CODE', <<'OUTPUT', 'Check that bug #16874 was fixed' );
1725		set S0, "foo "
1726		set S1, "bar "
1727		set S2, "quux "
1728		set S15, ""
1729		concat S15, S0
1730		concat S15, S1
1731		concat S15, S2
1732		print "["
1733		print S15
1734		print "]\n"
1735		end
1736		CODE
1737		[foo bar quux ]
1738		OUTPUT
1739
1740		pasm_output_is( <<'CODE', "all ok\n", 'stress concat' );
1741		set I0, 1000
1742		set S0, "michael"
1743		LOOP:
1744		set S2, I0
1745		concat S1, S0, S2
1746		concat S3, "mic", "hael"
1747		concat S3, S3, S2
1748		eq S1, S3, BOTTOM
1749		print "Failed: "
1750		print S1
1751		print " ne "
1752		print S3
1753		print "\n"
1754		end
1755		BOTTOM:
1756		sub I0, I0, 1
1757		ne I0, 0, LOOP
1758		print "all ok\n"
1759		end
1760		CODE
1761
1762		pasm_output_is( <<'CODE', <<'OUTPUT', 'ord and substring (see #17035)' );
1763		set S0, "abcdef"
1764		substr S1, S0, 2, 3
1765		ord I0, S0, 2
1766		ord I1, S1, 0
1767		ne I0, I1, fail
1768		ord I0, S0, 3
1769		ord I1, S1, 1
1770		ne I0, I1, fail
1771		ord I0, S0, 4
1772		ord I1, S1, 2
1773		ne I0, I1, fail
1774		print "It's all good\n"
1775		end
1776		fail:
1777		print "Not good: original string="
1778		print I0
1779		print ", substring="
1780		print I1
1781		print "\n"
1782		end
1783		CODE
1784		It's all good
1785		OUTPUT
1786
1787		pasm_output_is( <<'CODE', <<'OUTPUT', 'sprintf' );
	1248	.sub test_sprintf
1788	1249	branch MAIN
	1250	NEWARYP:
	1251	new $P1, 'ResizablePMCArray'
	1252	set $P1[0], $P0
	1253	local_return $P4
	1254	NEWARYS:
	1255	new $P1, 'ResizablePMCArray'
	1256	set $P1[0], $S0
	1257	local_return $P4
	1258	NEWARYI:
	1259	new $P1, 'ResizablePMCArray'
	1260	set $P1[0], $I0
	1261	local_return $P4
	1262	NEWARYN:
	1263	new $P1, 'ResizablePMCArray'
	1264	set $P1[0], $N0
	1265	local_return $P4
	1266	PRINTF:
	1267	sprintf $S2, $S1, $P1
	1268	is( $S2, $S99, $S1 )
	1269	local_return $P4
1789	1270
1790		NEWARYP:
1791		new P1, 'ResizablePMCArray'
1792		set P1[0], P0
1793		local_return P4
1794		NEWARYS:
1795		new P1, 'ResizablePMCArray'
1796		set P1[0], S0
1797		local_return P4
1798		NEWARYI:
1799		new P1, 'ResizablePMCArray'
1800		set P1[0], I0
1801		local_return P4
1802		NEWARYN:
1803		new P1, 'ResizablePMCArray'
1804		set P1[0], N0
1805		local_return P4
1806		PRINTF:
1807		sprintf S2, S1, P1
1808		print S2
1809		local_return P4
	1271	MAIN:
	1272	new $P4, 'ResizableIntegerArray'
	1273	set $S1, "Hello, %s"
	1274	set $S0, "Parrot!"
	1275	set $S99, "Hello, Parrot!"
	1276	local_branch $P4, NEWARYS
	1277	local_branch $P4, PRINTF
1810	1278
1811		MAIN:
1812		new P4, 'ResizableIntegerArray'
1813		set S1, "Hello, %s\n"
1814		set S0, "Parrot!"
1815		local_branch P4, NEWARYS
1816		local_branch P4, PRINTF
	1279	set $S1, "Hash[0x%x]"
	1280	set $I0, 256
	1281	set $S99, "Hash[0x100]"
	1282	local_branch $P4, NEWARYI
	1283	local_branch $P4, PRINTF
1817	1284
1818		set S1, "Hash[0x%x]\n"
1819		set I0, 256
1820		local_branch P4, NEWARYI
1821		local_branch P4, PRINTF
	1285	set $S1, "Hash[0x%lx]"
	1286	set $I0, 256
	1287	set $S99, "Hash[0x100]"
	1288	local_branch $P4, NEWARYI
	1289	local_branch $P4, PRINTF
1822	1290
1823		set S1, "Hash[0x%lx]\n"
1824		set I0, 256
1825		local_branch P4, NEWARYI
1826		local_branch P4, PRINTF
	1291	set $S1, "Hello, %.2s!"
	1292	set $S0, "Parrot"
	1293	set $S99, "Hello, Pa!"
	1294	local_branch $P4, NEWARYS
	1295	local_branch $P4, PRINTF
1827	1296
1828		set S1, "Hello, %.2s!\n"
1829		set S0, "Parrot"
1830		local_branch P4, NEWARYS
1831		local_branch P4, PRINTF
	1297	set $S1, "Hello, %Ss"
	1298	set $S0, $S2
	1299	set $S99, "Hello, Hello, Pa!"
	1300	local_branch $P4, NEWARYS
	1301	local_branch $P4, PRINTF
1832	1302
1833		set S1, "Hello, %Ss"
1834		set S0, S2
1835		local_branch P4, NEWARYS
1836		local_branch P4, PRINTF
	1303	set $S1, "1 == %Pd"
	1304	new $P0, 'Integer'
	1305	set $P0, 1
	1306	set $S99, "1 == 1"
	1307	local_branch $P4, NEWARYP
	1308	local_branch $P4, PRINTF
1837	1309
1838		set ~~S1, "1 == %Pd\n~~"
1839		~~new P0, 'Integer'~~
1840		set ~~P0, 1~~
1841		local_branch ~~P4, NEWARYP~~
1842		local_branch P4, PRINTF
	1310	set $S1, "-255 == %vd"
	1311	set $I0, -255
	1312	set $S99, "-255 == -255"
	1313	local_branch $P4, NEWARYI
	1314	local_branch $P4, PRINTF
1843	1315
1844		set S1, "-255 == %vd\n"
1845		set I0, -255
1846		local_branch P4, NEWARYI
1847		local_branch P4, PRINTF
	1316	set $S1, "+123 == %+vd"
	1317	set $I0, 123
	1318	set $S99, "+123 == +123"
	1319	local_branch $P4, NEWARYI
	1320	local_branch $P4, PRINTF
1848	1321
1849		set S1, "+123 == %+vd\n"
1850		set I0, 123
1851		local_branch P4, NEWARYI
1852		local_branch P4, PRINTF
	1322	set $S1, "256 == %vu"
	1323	set $I0, 256
	1324	set $S99, "256 == 256"
	1325	local_branch $P4, NEWARYI
	1326	local_branch $P4, PRINTF
1853	1327
1854		set S1, "256 == %vu\n"
1855		set I0, 256
1856		local_branch P4, NEWARYI
1857		local_branch P4, PRINTF
	1328	set $S1, "1 == %+vu"
	1329	set $I0, 1
	1330	set $S99, "1 == 1"
	1331	local_branch $P4, NEWARYI
	1332	local_branch $P4, PRINTF
1858	1333
1859		set S1, "1 == %+vu\n"
1860		set I0, 1
1861		local_branch P4, NEWARYI
1862		local_branch P4, PRINTF
	1334	set $S1, "001 == %0.3u"
	1335	set $I0, 1
	1336	set $S99, "001 == 001"
	1337	local_branch $P4, NEWARYI
	1338	local_branch $P4, PRINTF
1863	1339
1864		set S1, "001 == %0.3u\n"
1865		set I0, 1
1866		local_branch P4, NEWARYI
1867		local_branch P4, PRINTF
	1340	set $S1, "001 == %+0.3u"
	1341	set $I0, 1
	1342	set $S99, "001 == 001"
	1343	local_branch $P4, NEWARYI
	1344	local_branch $P4, PRINTF
1868	1345
1869		set S1, "001 == %+0.3u\n"
1870		set I0, 1
1871		local_branch P4, NEWARYI
1872		local_branch P4, PRINTF
	1346	set $S1, "0.500000 == %f"
	1347	set $N0, 0.5
	1348	set $S99, "0.500000 == 0.500000"
	1349	local_branch $P4, NEWARYN
	1350	local_branch $P4, PRINTF
1873	1351
1874		set S1, "0.500000 == %f\n"
1875		set N0, 0.5
1876		local_branch P4, NEWARYN
1877		local_branch P4, PRINTF
	1352	set $S1, "0.500 == %5.3f"
	1353	set $N0, 0.5
	1354	set $S99, "0.500 == 0.500"
	1355	local_branch $P4, NEWARYN
	1356	local_branch $P4, PRINTF
1878	1357
1879		set S1, "0.500 == %5.3f\n"
1880		set N0, 0.5
1881		local_branch P4, NEWARYN
1882		local_branch P4, PRINTF
	1358	set $S1, "0.001 == %g"
	1359	set $N0, 0.001
	1360	set $S99, "0.001 == 0.001"
	1361	local_branch $P4, NEWARYN
	1362	local_branch $P4, PRINTF
1883	1363
1884		set S1, "0.001 == %g\n"
1885		set N0, 0.001
1886		local_branch P4, NEWARYN
1887		local_branch P4, PRINTF
	1364	set $S1, "1e+06 == %g"
	1365	set $N0, 1.0e6
	1366	set $S99, "1e+06 == 1e+06"
	1367	local_branch $P4, NEWARYN
	1368	local_branch $P4, PRINTF
1888	1369
1889		set S1, "1e+06 == %g\n"
1890		set N0, 1.0e6
1891		local_branch P4, NEWARYN
1892		local_branch P4, PRINTF
	1370	set $S1, "0.5 == %3.3g"
	1371	set $N0, 0.5
	1372	set $S99, "0.5 == 0.5"
	1373	local_branch $P4, NEWARYN
	1374	local_branch $P4, PRINTF
1893	1375
1894		set S1, "0.5 == %3.3g\n"
1895		set N0, 0.5
1896		local_branch P4, NEWARYN
1897		local_branch P4, PRINTF
	1376	set $S1, "%% == %%"
	1377	set $I0, 0
	1378	set $S99, "% == %"
	1379	local_branch $P4, NEWARYI
	1380	local_branch $P4, PRINTF
1898	1381
1899		set S1, "%% == %%\n"
1900		set I0, 0
1901		local_branch P4, NEWARYI
1902		local_branch P4, PRINTF
	1382	set $S1, "That's all, %s"
	1383	set $S0, "folks!"
	1384	set $S99, "That's all, folks!"
	1385	local_branch $P4, NEWARYS
	1386	local_branch $P4, PRINTF
	1387	.end
1903	1388
1904		set S1, "That's all, %s\n"
1905		set S0, "folks!"
1906		local_branch P4, NEWARYS
1907		local_branch P4, PRINTF
	1389	.sub other_form_of_sprintf_op
	1390	new $P4, 'ResizableIntegerArray'
	1391	new $P3, 'String'
	1392	new $P2, 'String'
	1393	set $P2, "15 is %b"
	1394	new $P1, 'ResizablePMCArray'
	1395	set $P1[0], 15
	1396	sprintf $P3, $P2, $P1
	1397	is( $P3, "15 is 1111", 'other form of sprintf op' )
1908	1398
1909		end
1910		CODE
1911		Hello, Parrot!
1912		Hash[0x100]
1913		Hash[0x100]
1914		Hello, Pa!
1915		Hello, Hello, Pa!
1916		1 == 1
1917		-255 == -255
1918		+123 == +123
1919		256 == 256
1920		1 == 1
1921		001 == 001
1922		001 == 001
1923		0.500000 == 0.500000
1924		0.500 == 0.500
1925		0.001 == 0.001
1926		1e+06 == 1e+06
1927		0.5 == 0.5
1928		% == %
1929		That's all, folks!
1930		OUTPUT
	1399	new $P2, 'String'
	1400	set $P2, "128 is %o"
	1401	new $P1, 'ResizablePMCArray'
	1402	set $P1[0], 128
	1403	sprintf $P3, $P2, $P1
	1404	is( $P3, "128 is 200", 'other form of sprintf op' )
	1405	.end
1931	1406
1932		pasm_output_is( <<'CODE', <<'OUTPUT', 'other form of sprintf op' );
1933		branch MAIN
	1407	.sub sprintf_left_justify
	1408	$P0 = new 'ResizablePMCArray'
	1409	$P1 = new 'Integer'
	1410	$P1 = 10
	1411	$P0[0] = $P1
	1412	$P1 = new 'String'
	1413	$P1 = "foo"
	1414	$P0[1] = $P1
	1415	$P1 = new 'String'
	1416	$P1 = "bar"
	1417	$P0[2] = $P1
	1418	$S0 = sprintf "%-*s - %s", $P0
	1419	is( $S0, "foo - bar", 'sprintf - left justify' )
	1420	.end
1934	1421
1935		~~PRINTF:~~
1936		~~sprintf P3, P2, P1~~
1937		~~print P3~~
1938		~~local_return P4~~
1939	1422
1940		MAIN:
1941		new P4, 'ResizableIntegerArray'
1942		new P3, 'String'
	1423	.sub correct_precision_for_sprintf_x
	1424	.include "iglobals.pasm"
1943	1425
1944		new P2, 'String'
1945		set P2, "15 is %b\n"
1946		new P1, 'ResizablePMCArray'
1947		set P1[0], 15
1948		local_branch P4, PRINTF
	1426	# Create the string via concat
	1427	.local pmc interp # a handle to our interpreter object.
	1428	interp = getinterp
	1429	.local pmc config
	1430	config = interp[.IGLOBALS_CONFIG_HASH]
	1431	.local int intvalsize
	1432	intvalsize = config['intvalsize']
1949	1433
1950		new P2, 'String'
1951		set P2, "128 is %o\n"
1952		new P1, 'ResizablePMCArray'
1953		set P1[0], 128
1954		local_branch P4, PRINTF
	1434	$S0 = ''
	1435	$I0 = 1
	1436	$I1 = intvalsize * 2
	1437	loop:
	1438	concat $S0, 'f'
	1439	inc $I0
	1440	le $I0, $I1, loop
	1441	padding_loop:
	1442	concat $S0, ' '
	1443	inc $I0
	1444	le $I0, 20, padding_loop
	1445
	1446	# Now see what sprintf comes up with
	1447	$P0 = new 'ResizablePMCArray'
	1448	$P0[0] = -1
	1449	$S1 = sprintf "%-20x", $P0
	1450	is( $S1, $S0, 'Correct precision for %x' )
	1451	.end
1955	1452
1956		end
1957		CODE
1958		15 is 1111
1959		128 is 200
1960		OUTPUT
	1453	.sub test_exchange
	1454	set $S0, "String #0"
	1455	set $S1, "String #1"
	1456	exchange $S0, $S1
	1457	is( $S0, "String #1", 'exchange' )
	1458	is( $S1, "String #0", 'exchange' )
	1459
	1460	set $S2, "String #2"
	1461	exchange $S2, $S2
	1462	is( $S2, "String #2", 'exchange' )
	1463	.end
1961	1464
1962		pir_output_is( <<'CODE', <<'OUTPUT', 'sprintf - left justify' );
1963		.sub main :main
1964		$P0 = new 'ResizablePMCArray'
1965		$P1 = new 'Integer'
1966		$P1 = 10
1967		$P0[0] = $P1
1968		$P1 = new 'String'
1969		$P1 = "foo"
1970		$P0[1] = $P1
1971		$P1 = new 'String'
1972		$P1 = "bar"
1973		$P0[2] = $P1
1974		$S0 = sprintf "%-*s - %s\n", $P0
1975		print $S0
1976		end
	1465	.sub test_find_encoding
	1466	skip( 4, "Pending reimplementation of find_encoding" )
	1467	# find_encoding $I0, "singlebyte"
	1468	# is( $I0, "0", 'find_encoding' )
	1469	# find_encoding $I0, "utf8"
	1470	# is( $I0, "1", 'find_encoding' )
	1471	# find_encoding $I0, "utf16"
	1472	# is( $I0, "2", 'find_encoding' )
	1473	# find_encoding $I0, "utf32"
	1474	# is( $I0, "3", 'find_encoding' )
1977	1475	.end
1978		~~CODE~~
1979		~~foo - bar~~
1980		~~OUTPUT~~
1981	1476
1982		{
1983		my $output = substr( ( 'f' x ( $PConfig{intvalsize} * 2 ) ) . ( ' ' x 20 ), 0, 20 );
1984		pir_output_is( <<'CODE', $output, 'Correct precision for %x' ); }
1985		.sub main :main
1986		$P0 = new 'ResizablePMCArray'
1987		$P0[0] = -1
1988		$S0 = sprintf "%-20x", $P0
1989		print $S0
1990		end
	1477	.sub test_string_encoding
	1478	skip(4, "no more visible encoding" )
	1479	# set $I0, 0
	1480	# new $S0, 0, $I0
	1481	# string_encoding $I1, $S0
	1482	# eq $I0, $I1, OK1
	1483	# print "not "
	1484	# OK1: print "ok 1\n"
	1485	# set $I0, 1
	1486	# new $S0, 0, $I0
	1487	# string_encoding $I1, $S0
	1488	# eq $I0, $I1, OK2
	1489	# print "not "
	1490	# OK2: print "ok 2\n"
	1491	# set $I0, 2
	1492	# new $S0, 0, $I0
	1493	# string_encoding $I1, $S0
	1494	# eq $I0, $I1, OK3
	1495	# print "not "
	1496	# OK3: print "ok 3\n"
	1497	# set $I0, 3
	1498	# new $S0, 0, $I0
	1499	# string_encoding $I1, $S0
	1500	# eq $I0, $I1, OK4
	1501	# print "not "
	1502	# OK4: print "ok 4\n"
1991	1503	.end
1992		~~CODE~~
1993	1504
1994		pasm_output_is( <<'CODE', <<'OUTPUT', 'exchange' );
1995		set ~~S0, "String #0\n~~"
1996		~~set S1, "String #1\n"~~
1997		~~exchange S0, S1~~
1998		~~print S0~~
1999		print S1
	1505	.sub test_assign
	1506	set $S4, "JAPH"
	1507	assign $S5, $S4
	1508	is( $S4, "JAPH", 'assign' )
	1509	is( $S5, "JAPH", 'assign' )
	1510	.end
2000	1511
2001		set S2, "String #2\n"
2002		exchange S2, S2
2003		print S2
	1512	.sub assign_and_globber
	1513	set $S4, "JAPH"
	1514	assign $S5, $S4
	1515	assign $S4, "Parrot"
	1516	is( $S4, "Parrot", 'assign & globber' )
	1517	is( $S5, "JAPH", 'assign & globber' )
	1518	.end
2004	1519
2005		end
2006		CODE
2007		String #1
2008		String #0
2009		String #2
2010		OUTPUT
	1520	.sub assign_and_globber_2
	1521	set $S4, "JAPH"
	1522	set $S5, $S4
	1523	assign $S4, "Parrot"
	1524	is( $S4, "Parrot", 'assign & globber 2' )
	1525	is( $S5, "Parrot", 'assign & globber 2' )
	1526	.end
2011	1527
2012		SKIP: {
2013		skip( "Pending reimplementation of find_encoding", 1 );
2014		pasm_output_is( <<'CODE', <<'OUTPUT', 'find_encoding' );
2015		find_encoding I0, "singlebyte"
2016		print I0
2017		print "\n"
2018		find_encoding I0, "utf8"
2019		print I0
2020		print "\n"
2021		find_encoding I0, "utf16"
2022		print I0
2023		print "\n"
2024		find_encoding I0, "utf32"
2025		print I0
2026		print "\n"
2027		end
2028		CODE
2029		0
2030		1
2031		2
2032		3
2033		OUTPUT
2034		}
	1528	.sub bands_null_string
	1529	null $S1
	1530	set $S2, "abc"
	1531	bands $S1, $S2
	1532	null $S3
	1533	is( $S1, $S3, 'ok1' )
2035	1534
2036		SKIP: {
2037		skip( "no more visible encoding", 1 );
2038		pasm_output_is( <<'CODE', <<'OUTPUT', 'string_encoding' );
2039		set I0, 0
2040		new S0, 0, I0
2041		string_encoding I1, S0
2042		eq I0, I1, OK1
2043		print "not "
2044		OK1: print "ok 1\n"
	1535	set $S1, ""
	1536	bands $S1, $S2
	1537	nok( $S1, 'ok2' )
	1538
	1539	null $S2
	1540	set $S1, "abc"
	1541	bands $S1, $S2
	1542	null $S3
	1543	is( $S1, $S3, 'ok3' )
	1544
	1545	set $S2, ""
	1546	bands $S1, $S2
	1547	nok( $S1, 'ok4' )
	1548	.end
2045	1549
2046		set I0, 1
2047		new S0, 0, I0
2048		string_encoding I1, S0
2049		eq I0, I1, OK2
2050		print "not "
2051		OK2: print "ok 2\n"
	1550	.sub bands_2
	1551	set $S1, "abc"
	1552	set $S2, "EE"
	1553	bands $S1, $S2
	1554	is( $S1, "A@", 'bands 2' )
	1555	is( $S2, "EE", 'bands 2' )
	1556	.end
2052	1557
2053		set I0, 2
2054		new S0, 0, I0
2055		string_encoding I1, S0
2056		eq I0, I1, OK3
2057		print "not "
2058		OK3: print "ok 3\n"
	1558	.sub bands_3
	1559	set $S1, "abc"
	1560	set $S2, "EE"
	1561	bands $S0, $S1, $S2
	1562	is( $S0, "A@", 'bands 3' )
	1563	is( $S1, "abc", 'bands 3' )
	1564	is( $S2, "EE", 'bands 3' )
	1565	.end
2059	1566
2060		set I0, 3
2061		~~new S0, 0, I0~~
2062		~~string_encoding I1, S0~~
2063		~~eq I0, I1, OK4~~
2064		~~print "not "~~
2065		OK4: print "ok 4\n"
	1567	.sub bands_cow
	1568	set $S1, "foo"
	1569	substr $S2, $S1, 0, 3
	1570	bands $S1, "bar"
	1571	is( $S2, "foo", 'bands COW' )
	1572	.end
2066	1573
2067		end
2068		CODE
2069		ok 1
2070		ok 2
2071		ok 3
2072		ok 4
2073		OUTPUT
2074		}
	1574	.sub bors_null_string
	1575	null $S1
	1576	null $S2
	1577	bors $S1, $S2
	1578	null $S3
	1579	is( $S1, $S3, 'bors NULL string' )
2075	1580
2076		pasm_output_is( <<'CODE', <<'OUTPUT', 'assign' );
2077		set S4, "JAPH\n"
2078		assign S5, S4
2079		print S4
2080		print S5
2081		end
2082		CODE
2083		JAPH
2084		JAPH
2085		OUTPUT
	1581	null $S1
	1582	set $S2, ""
	1583	bors $S1, $S2
	1584	null $S3
	1585	is( $S1, $S3, 'bors NULL string' )
	1586
	1587	bors $S2, $S1
	1588	is( $S2, $S3, 'bors NULL string' )
2086	1589
2087		pasm_output_is( <<'CODE', <<'OUTPUT', 'assign & globber' );
2088		set S4, "JAPH\n"
2089		assign S5, S4
2090		assign S4, "Parrot\n"
2091		print S4
2092		print S5
2093		end
2094		CODE
2095		Parrot
2096		JAPH
2097		OUTPUT
	1590	null $S1
	1591	set $S2, "def"
	1592	bors $S1, $S2
	1593	is( $S1, "def", 'bors NULL string' )
2098	1594
2099		pasm_output_is( <<'CODE', <<'OUTPUT', 'assign & globber 2' );
2100		set S4, "JAPH\n"
2101		set S5, S4
2102		assign S4, "Parrot\n"
2103		print S4
2104		print S5
2105		end
2106		CODE
2107		Parrot
2108		Parrot
2109		OUTPUT
	1595	null $S2
	1596	bors $S1, $S2
	1597	is( $S1, "def", 'bors NULL string' )
2110	1598
2111		pasm_output_is( <<'CODE', <<'OUTPUT', 'bands NULL string' );
2112		null S1
2113		set S2, "abc"
2114		bands S1, S2
2115		null S3
2116		eq S1, S3, ok1
2117		print "not "
2118		ok1: print "ok 1\n"
2119		set S1, ""
2120		bands S1, S2
2121		unless S1, ok2
2122		print "not "
2123		ok2: print "ok 2\n"
	1599	null $S1
	1600	null $S2
	1601	bors $S3, $S1, $S2
	1602	null $S4
	1603	is( $S3, $S4, 'bors NULL string' )
2124	1604
2125		null S2
2126		set S1, "abc"
2127		bands S1, S2
2128		null S3
2129		eq S1, S3, ok3
2130		print "not "
2131		ok3: print "ok 3\n"
2132		set S2, ""
2133		bands S1, S2
2134		unless S1, ok4
2135		print "not "
2136		ok4: print "ok 4\n"
2137		end
2138		CODE
2139		ok 1
2140		ok 2
2141		ok 3
2142		ok 4
2143		OUTPUT
	1605	set $S1, ""
	1606	bors $S3, $S1, $S2
	1607	is( $S3, $S4, 'bors NULL string' )
2144	1608
2145		pasm_output_is( <<'CODE', <<'OUTPUT', 'bands 2' );
2146		set S1, "abc"
2147		set S2, "EE"
2148		bands S1, S2
2149		print S1
2150		print "\n"
2151		print S2
2152		print "\n"
2153		end
2154		CODE
2155		A@
2156		EE
2157		OUTPUT
	1609	bors $S3, $S2, $S1
	1610	is( $S3, $S4, 'bors NULL string' )
2158	1611
2159		pasm_output_is( <<'CODE', <<'OUTPUT', 'bands 3' );
2160		set S1, "abc"
2161		set S2, "EE"
2162		bands S0, S1, S2
2163		print S0
2164		print "\n"
2165		print S1
2166		print "\n"
2167		print S2
2168		print "\n"
2169		end
2170		CODE
2171		A@
2172		abc
2173		EE
2174		OUTPUT
	1612	set $S1, "def"
	1613	bors $S3, $S1, $S2
	1614	is( $S3, "def", 'bors NULL string' )
2175	1615
2176		pasm_output_is( <<'CODE', <<'OUTPUT', 'bands COW' );
2177		set S1, "foo"
2178		substr S2, S1, 0, 3
2179		bands S1, "bar"
2180		print S2
2181		print "\n"
2182		end
2183		CODE
2184		foo
2185		OUTPUT
	1616	bors $S3, $S2, $S1
	1617	is( $S3, "def", 'bors NULL string' )
	1618	.end
2186	1619
2187		pasm_output_is( <<'CODE', <<'OUTPUT', 'bors NULL string' );
2188		null S1
2189		null S2
2190		bors S1, S2
2191		null S3
2192		eq S1, S3, OK1
2193		print "not "
2194		OK1: print "ok 1\n"
	1620	.sub bors_2
	1621	set $S1, "abc"
	1622	set $S2, "EE"
	1623	bors $S1, $S2
	1624	is( $S1, "egc", 'bors 2' )
	1625	is( $S2, "EE", 'bors 2' )
	1626	.end
2195	1627
2196		null S1
2197		set S2, ""
2198		bors S1, S2
2199		null S3
2200		eq S1, S3, OK2
2201		print "not "
2202		OK2: print "ok 2\n"
2203		bors S2, S1
2204		eq S2, S3, OK3
2205		print "not "
2206		OK3: print "ok 3\n"
	1628	.sub bors_3
	1629	set $S1, "abc"
	1630	set $S2, "EE"
	1631	bors $S0, $S1, $S2
	1632	is( $S0, "egc", 'bors 3' )
	1633	is( $S1, "abc", 'bors 3' )
	1634	is( $S2, "EE", 'bors 3' )
	1635	.end
2207	1636
2208		null S1
2209		set S2, "def"
2210		bors S1, S2
2211		eq S1, "def", OK4
2212		print "not "
2213		OK4: print "ok 4\n"
2214		null S2
2215		bors S1, S2
2216		eq S1, "def", OK5
2217		print "not "
2218		OK5: print "ok 5\n"
	1637	.sub bors_cow
	1638	set $S1, "foo"
	1639	substr $S2, $S1, 0, 3
	1640	bors $S1, "bar"
	1641	is( $S2, "foo", 'bors COW' )
	1642	.end
2219	1643
2220		null S1
2221		null S2
2222		bors S3, S1, S2
2223		null S4
2224		eq S3, S4, OK6
2225		print "not "
2226		OK6: print "ok 6\n"
	1644	.sub bxors_null_string
	1645	null $S1
	1646	null $S2
	1647	bxors $S1, $S2
	1648	null $S3
	1649	is( $S1, $S3, 'bxors NULL string' )
2227	1650
2228		set S1, ""
2229		bors S3, S1, S2
2230		eq S3, S4, OK7
2231		print "not "
2232		OK7: print "ok 7\n"
2233		bors S3, S2, S1
2234		eq S3, S4, OK8
2235		print "not "
2236		OK8: print "ok 8\n"
	1651	null $S1
	1652	set $S2, ""
	1653	bxors $S1, $S2
	1654	null $S3
	1655	is( $S1, $S3, 'bxors NULL string' )
2237	1656
2238		set S1, "def"
2239		bors S3, S1, S2
2240		eq S3, "def", OK9
2241		print "not "
2242		OK9: print "ok 9\n"
2243		bors S3, S2, S1
2244		eq S3, "def", OK10
2245		print "not "
2246		OK10: print "ok 10\n"
2247		end
2248		CODE
2249		ok 1
2250		ok 2
2251		ok 3
2252		ok 4
2253		ok 5
2254		ok 6
2255		ok 7
2256		ok 8
2257		ok 9
2258		ok 10
2259		OUTPUT
	1657	bxors $S2, $S1
	1658	is( $S2, $S3, 'bxors NULL string' )
2260	1659
2261		pasm_output_is( <<'CODE', <<'OUTPUT', 'bors 2' );
2262		set S1, "abc"
2263		set S2, "EE"
2264		bors S1, S2
2265		print S1
2266		print "\n"
2267		print S2
2268		print "\n"
2269		end
2270		CODE
2271		egc
2272		EE
2273		OUTPUT
	1660	null $S1
	1661	set $S2, "abc"
	1662	bxors $S1, $S2
	1663	is( $S1, "abc", 'bxors NULL string' )
2274	1664
2275		pasm_output_is( <<'CODE', <<'OUTPUT', 'bors 3' );
2276		set S1, "abc"
2277		set S2, "EE"
2278		bors S0, S1, S2
2279		print S0
2280		print "\n"
2281		print S1
2282		print "\n"
2283		print S2
2284		print "\n"
2285		end
2286		CODE
2287		egc
2288		abc
2289		EE
2290		OUTPUT
	1665	null $S2
	1666	bxors $S1, $S2
	1667	is( $S1, "abc", 'bxors NULL string' )
2291	1668
2292		pasm_output_is( <<'CODE', <<'OUTPUT', 'bors COW' );
2293		set S1, "foo"
2294		substr S2, S1, 0, 3
2295		bors S1, "bar"
2296		print S2
2297		print "\n"
2298		end
2299		CODE
2300		foo
2301		OUTPUT
	1669	null $S1
	1670	null $S2
	1671	bxors $S3, $S1, $S2
	1672	null $S4
	1673	is( $S3, $S4, 'bxors NULL string' )
2302	1674
2303		pasm_output_is( <<'CODE', <<'OUTPUT', 'bxors NULL string' );
2304		null S1
2305		null S2
2306		bxors S1, S2
2307		null S3
2308		eq S1, S3, OK1
2309		print "not "
2310		OK1: print "ok 1\n"
	1675	set $S1, ""
	1676	bxors $S3, $S1, $S2
	1677	is( $S3, $S4, 'bxors NULL string' )
2311	1678
2312		null S1
2313		set S2, ""
2314		bxors S1, S2
2315		null S3
2316		eq S1, S3, OK2
2317		print "not "
2318		OK2: print "ok 2\n"
2319		bxors S2, S1
2320		eq S2, S3, OK3
2321		print "not "
2322		OK3: print "ok 3\n"
	1679	bxors $S3, $S2, $S1
	1680	is( $S3, $S4, 'bxors NULL string' )
2323	1681
2324		null S1
2325		set S2, "abc"
2326		bxors S1, S2
2327		eq S1, "abc", OK4
2328		print "not "
2329		OK4: print "ok 4\n"
2330		null S2
2331		bxors S1, S2
2332		eq S1, "abc", OK5
2333		print "not "
2334		OK5: print "ok 5\n"
	1682	set $S1, "abc"
	1683	bxors $S3, $S1, $S2
	1684	is( $S3, "abc", 'bxors NULL string' )
2335	1685
2336		null S1
2337		null S2
2338		bxors S3, S1, S2
2339		null S4
2340		eq S3, S4, OK6
2341		print "not "
2342		OK6: print "ok 6\n"
	1686	bxors $S3, $S2, $S1
	1687	is( $S3, "abc", 'bxors NULL string' )
	1688	.end
2343	1689
2344		set S1, ""
2345		bxors S3, S1, S2
2346		eq S3, S4, OK7
2347		print "not "
2348		OK7: print "ok 7\n"
2349		bxors S3, S2, S1
2350		eq S3, S4, OK8
2351		print "not "
2352		OK8: print "ok 8\n"
	1690	.sub bxors_2
	1691	set $S1, "a2c"
	1692	set $S2, "Dw"
	1693	bxors $S1, $S2
	1694	is( $S1, "%Ec", 'bxors 2' )
	1695	is( $S2, "Dw", 'bxors 2' )
	1696
	1697	set $S1, "abc"
	1698	set $S2, " X"
	1699	bxors $S1, $S2
	1700	is( $S1, "ABCX", 'bxors 2' )
	1701	is( $S2, " X", 'bxors 2' )
	1702	.end
2353	1703
2354		set S1, "abc"
2355		bxors S3, S1, S2
2356		eq S3, "abc", OK9
2357		print "not "
2358		OK9: print "ok 9\n"
2359		bxors S3, S2, S1
2360		eq S3, "abc", OK10
2361		print "not "
2362		OK10: print "ok 10\n"
2363		end
2364		CODE
2365		ok 1
2366		ok 2
2367		ok 3
2368		ok 4
2369		ok 5
2370		ok 6
2371		ok 7
2372		ok 8
2373		ok 9
2374		ok 10
2375		OUTPUT
	1704	.sub bxors_3
	1705	set $S1, "a2c"
	1706	set $S2, "Dw"
	1707	bxors $S0, $S1, $S2
	1708	is( $S0, "%Ec", 'bxors 3' )
	1709	is( $S1, "a2c", 'bxors 3' )
	1710	is( $S2, "Dw", 'bxors 3' )
	1711
	1712	set $S1, "abc"
	1713	set $S2, " Y"
	1714	bxors $S0, $S1, $S2
	1715	is( $S0, "ABCY", 'bxors 3' )
	1716	is( $S1, "abc", 'bxors 3' )
	1717	is( $S2, " Y", 'bxors 3' )
	1718	.end
2376	1719
2377		# string_133.pasm, used for t/native_pbc/string.t
2378		pasm_output_is( <<'CODE', <<'OUTPUT', 'bxors 2' );
2379		set S1, "a2c"
2380		set S2, "Dw"
2381		bxors S1, S2
2382		print S1
2383		print "\n"
2384		print S2
2385		print "\n"
2386		set S1, "abc"
2387		set S2, " X"
2388		bxors S1, S2
2389		print S1
2390		print "\n"
2391		print S2
2392		print "\n"
2393		end
2394		CODE
2395		%Ec
2396		Dw
2397		ABCX
2398		X
2399		OUTPUT
	1720	.sub bxors_cow
	1721	set $S1, "foo"
	1722	substr $S2, $S1, 0, 3
	1723	bxors $S1, "bar"
	1724	is( $S2, "foo", 'bxors COW' )
	1725	.end
2400	1726
2401		pasm_output_is( <<'CODE', <<'OUTPUT', 'bxors 3' );
2402		set S1, "a2c"
2403		set S2, "Dw"
2404		bxors S0, S1, S2
2405		print S0
2406		print "\n"
2407		print S1
2408		print "\n"
2409		print S2
2410		print "\n"
2411		set S1, "abc"
2412		set S2, " Y"
2413		bxors S0, S1, S2
2414		print S0
2415		print "\n"
2416		print S1
2417		print "\n"
2418		print S2
2419		print "\n"
2420		end
2421		CODE
2422		%Ec
2423		a2c
2424		Dw
2425		ABCY
2426		abc
2427		Y
2428		OUTPUT
	1727	.sub bnots_null_string
	1728	null $S1
	1729	null $S2
	1730	bnots $S1, $S2
	1731	null $S3
	1732	is( $S1, $S3, 'bnots NULL string' )
2429	1733
2430		pasm_output_is( <<'CODE', <<'OUTPUT', 'bxors COW' );
2431		set S1, "foo"
2432		substr S2, S1, 0, 3
2433		bxors S1, "bar"
2434		print S2
2435		print "\n"
2436		end
2437		CODE
2438		foo
2439		OUTPUT
	1734	null $S1
	1735	set $S2, ""
	1736	bnots $S1, $S2
	1737	null $S3
	1738	is( $S1, $S3, 'bnots NULL string' )
	1739
	1740	bnots $S2, $S1
	1741	is( $S2, $S3, 'bnots NULL string' )
	1742	.end
2440	1743
2441		pasm_output_is( <<'CODE', <<'OUTPUT', 'bnots NULL string' );
2442		null S1
2443		null S2
2444		bnots S1, S2
2445		null S3
2446		eq S1, S3, OK1
2447		print "not "
2448		OK1: print "ok 1\n"
	1744	# This was the previous test used for t/native_pbc/string.t
	1745	.sub bnots_2
	1746	skip( 4, "No unicode yet" )
	1747	# getstdout $P0
	1748	# push $P0, "utf8"
	1749	# set $S1, "a2c"
	1750	# bnots $S2, $S1
	1751	# is( $S1, "a2c", 'bnots 2' )
	1752	# is( $S2, "\xC2\x9E\xC3\x8D\xC2\x9C", 'bnots 2' )
	1753	#
	1754	# bnots $S1, $S1
	1755	# is( $S1, "\xC2\x9E\xC3\x8D\xC2\x9C", 'bnots 2' )
	1756	#
	1757	# bnots $S1, $S1
	1758	# is( $S1, "a2c", 'bnots 2' )
	1759	.end
2449	1760
2450		null S1
2451		set S2, ""
2452		bnots S1, S2
2453		null S3
2454		eq S1, S3, OK2
2455		print "not "
2456		OK2: print "ok 2\n"
2457		bnots S2, S1
2458		eq S2, S3, OK3
2459		print "not "
2460		OK3: print "ok 3\n"
2461		end
2462		CODE
2463		ok 1
2464		ok 2
2465		ok 3
2466		OUTPUT
	1761	.sub bnots_cow
	1762	set $S1, "foo"
	1763	substr $S2, $S1, 0, 3
	1764	bnots $S1, $S1
	1765	is( $S2, "foo", 'bnots COW' )
	1766	.end
2467	1767
2468		SKIP: {
2469		skip( "No unicode yet", 1 );
2470		# This was the previous test used for t/native_pbc/string.t
2471		pasm_output_is( <<'CODE', <<'OUTPUT', 'bnots 2' );
2472		getstdout P0
2473		push P0, "utf8"
2474		set S1, "a2c"
2475		bnots S2, S1
2476		print S1
2477		print "\n"
2478		print S2
2479		print "\n"
2480		bnots S1, S1
2481		print S1
2482		print "\n"
2483		bnots S1, S1
2484		print S1
2485		print "\n"
2486		end
2487		CODE
2488		a2c
2489		\xC2\x9E\xC3\x8D\xC2\x9C
2490		\xC2\x9E\xC3\x8D\xC2\x9C
2491		a2c
2492		OUTPUT
2493		}
	1768	.sub transcode_to_utf8
	1769	skip( 2, "no more transcode" )
	1770	# set $S1, "ASCII is the same as UTF8\n"
	1771	# find_encoding $I1, "utf8"
	1772	# transcode $S2, $S1, $I1
	1773	# is( $S1, "ASCII is the same as UTF8", 'transcode to utf8' )
	1774	# is( $S2, "ASCII is the same as UTF8", 'transcode to utf8' )
	1775	.end
2494	1776
2495		pasm_output_is( <<'CODE', <<'OUTPUT', 'bnots COW' );
2496		set S1, "foo"
2497		substr S2, S1, 0, 3
2498		bnots S1, S1
2499		print S2
2500		print "\n"
2501		end
2502		CODE
2503		foo
2504		OUTPUT
	1777	.sub string_chartype
	1778	skip( 1, "no more chartype" )
2505	1779
2506		SKIP: {
2507		skip( "no more transcode", 1 );
2508		pasm_output_is( <<'CODE', <<'OUTPUT', 'transcode to utf8' );
2509		set S1, "ASCII is the same as UTF8\n"
2510		find_encoding I1, "utf8"
2511		transcode S2, S1, I1
2512		print S1
2513		print S2
2514		end
2515		CODE
2516		ASCII is the same as UTF8
2517		ASCII is the same as UTF8
2518		OUTPUT
2519		}
	1780	# set $S0, "Test String"
	1781	# find_chartype $I0, "usascii"
	1782	# set_chartype $S0, $I0
	1783	# string_chartype $I1, $S0
	1784	# is( $I0, $I1, 'string_chartype' )
	1785	.end
2520	1786
2521		SKIP: {
2522		skip( "no more chartype", 1 );
2523		pasm_output_is( <<'CODE', <<'OUTPUT', 'string_chartype' );
2524		set S0, "Test String"
2525		find_chartype I0, "usascii"
2526		set_chartype S0, I0
2527		string_chartype I1, S0
2528		eq I1, I0, OK
2529		print I0
2530		print "\n"
2531		print I1
2532		print "\n"
2533		print "not "
2534		OK: print "ok\n"
2535		end
2536		CODE
2537		ok
2538		OUTPUT
2539		}
	1787	.sub split_on_empty_string
	1788	split $P1, "", ""
	1789	set $I1, $P1
	1790	is( $I1, "0", 'split on empty string' )
	1791
	1792	split $P0, "", "ab"
	1793	set $I0, $P0
	1794	is( $I0, "2", 'split on empty string' )
	1795
	1796	set $S0, $P0[0]
	1797	is( $S0, "a", 'split on empty string' )
	1798
	1799	set $S0, $P0[1]
	1800	is( $S0, "b", 'split on empty string' )
	1801	.end
2540	1802
2541		# Set all string registers to values given by &$_[0](reg num)
2542		sub set_str_regs {
2543		my $code = shift;
2544		my $rt;
2545		for ( 0 .. 31 ) {
2546		$rt .= "\tset S$_, \"" . &$code($_) . "\"\n";
2547		}
2548		return $rt;
2549		}
2550
2551		# print string registers, no additional prints
2552		sub print_str_regs {
2553		my $rt;
2554		for ( 0 .. 31 ) {
2555		$rt .= "\tprint S$_\n";
2556		}
2557		return $rt;
2558		}
2559
2560		# Generate code to compare each pair of strings in a list
2561		sub compare_strings {
2562		my $const = shift;
2563		my $op = shift;
2564		my @strings = @_;
2565		my $i = 1;
2566		my $rt;
2567		while (@strings) {
2568		my $s1 = shift @strings;
2569		my $s2 = shift @strings;
2570		my $arg1;
2571		my $arg2;
2572		if ( $const == 3 ) {
2573		$arg1 = "\"$s1\"";
2574		$arg2 = "\"$s2\"";
2575		}
2576		elsif ( $const == 2 ) {
2577		$rt .= " set S0, \"$s1\"\n";
2578		$arg1 = "S0";
2579		$arg2 = "\"$s2\"";
2580		}
2581		elsif ( $const == 1 ) {
2582		$rt .= " set S0, \"$s2\"\n";
2583		$arg1 = "\"$s1\"";
2584		$arg2 = "S0";
2585		}
2586		else {
2587		$rt .= " set S0, \"$s1\"\n";
2588		$rt .= " set S1, \"$s2\"\n";
2589		$arg1 = "S0";
2590		$arg2 = "S1";
2591		}
2592		if ( eval "\"$s1\" $op \"$s2\"" ) {
2593		$rt .= " $op $arg1, $arg2, OK$i\n";
2594		$rt .= " branch ERROR\n";
2595		}
2596		else {
2597		$rt .= " $op $arg1, $arg2, ERROR\n";
2598		}
2599		$rt .= "OK$i:\n";
2600		$i++;
2601		}
2602		return $rt;
2603		}
2604
2605		pasm_output_is( <<'CODE', <<'OUTPUT', 'split on empty string' );
2606		_main:
2607		split P1, "", ""
2608		set I1, P1
2609		print I1
2610		print "\n"
2611		split P0, "", "ab"
2612		set I0, P0
2613		print I0
2614		print "\n"
2615		set S0, P0[0]
2616		print S0
2617		set S0, P0[1]
2618		print S0
2619		print "\n"
2620		end
2621		CODE
2622		0
2623		2
2624		ab
2625		OUTPUT
2626
2627		pasm_output_is( <<'CODE', <<'OUTPUT', 'split on non-empty string' );
2628		_main:
2629		split P0, "a", "afooabara"
2630		set I0, P0
2631		print I0
2632		print "\n"
2633		set I1, 0
2634		loop:
2635		set S0, P0[I1]
2636		print S0
2637		print "\n"
2638		inc I1
2639		sub I2, I1, I0
2640		if I2, loop
2641		end
2642		CODE
2643		5
2644
2645		foo
2646		b
2647		r
2648
2649		OUTPUT
2650
2651		pir_output_is( <<'CODE', <<'OUTPUT', 'split HLL mapped' );
2652		.HLL 'foohll'
2653		.sub main
2654		.local pmc RSA, fooRSA
2655		RSA = get_class ['ResizableStringArray']
2656		fooRSA = subclass ['ResizableStringArray'], 'fooRSA'
2657		.local pmc interp
2658		interp = getinterp
2659		interp.'hll_map'(RSA, fooRSA)
2660		.local pmc a
2661		split a, "a", "afooabara"
2662		.local string t
2663		t = typeof a
2664		say t
2665		.local int n, i
2666		n = a
2667		say n
2668		i = 0
2669		loop:
2670		.local string s
2671		s = a[i]
2672		say s
2673		inc i
2674		if i != n goto loop
	1803	.sub split_on_non_empty_string
	1804	split $P0, "a", "afooabara"
	1805	set $I0, $P0
	1806	is( $I0, "5", 'split on non-empty string' )
	1807
	1808	set $S0, $P0[0]
	1809	is( $S0, "", 'split on non-empty string' )
	1810	set $S0, $P0[1]
	1811	is( $S0, "foo", 'split on non-empty string' )
	1812	set $S0, $P0[2]
	1813	is( $S0, "b", 'split on non-empty string' )
	1814	set $S0, $P0[3]
	1815	is( $S0, "r", 'split on non-empty string' )
	1816	set $S0, $P0[4]
	1817	is( $S0, "", 'split on non-empty string' )
2675	1818	.end
2676		~~CODE~~
2677		~~fooRSA~~
2678		5
2679	1819
2680		foo
2681		b
2682		r
	1820	.sub test_join
	1821	new $P0, 'ResizablePMCArray'
	1822	join $S0, "--", $P0
	1823	is( $S0, "", 'join' )
2683	1824
2684		OUTPUT
2685
2686		pasm_output_is( <<'CODE', <<'OUTPUT', 'join' );
2687		_main:
2688		new P0, 'ResizablePMCArray'
2689		join S0, "--", P0
2690		print S0
2691		print "\n"
2692		push P0, "a"
2693		join S0, "--", P0
2694		print S0
2695		print "\n"
2696		new P0, 'ResizablePMCArray'
2697		push P0, "a"
2698		push P0, "b"
2699		join S0, "--", P0
2700		print S0
2701		print "\n"
2702		end
2703		CODE
2704
2705		a
2706		a--b
2707		OUTPUT
2708
2709		pir_output_is( <<'CODE', <<'OUTPUT', 'join: get_string returns a null string' );
2710
2711		.sub _main
2712		newclass $P0, "Foo"
2713
	1825	push $P0, "a"
	1826	join $S0, "--", $P0
	1827	is( $S0, "a", 'join' )
	1828
2714	1829	new $P0, 'ResizablePMCArray'
	1830	push $P0, "a"
	1831	push $P0, "b"
	1832	join $S0, "--", $P0
	1833	is( $S0, "a--b", 'join' )
	1834	.end
2715	1835
2716		$P1 = new "Foo"
2717
	1836	# join: get_string returns a null string --------
	1837	.namespace ["Foo5"]
	1838	.sub get_string :vtable :method
	1839	.local string ret
	1840	null ret
	1841	.begin_return
	1842	.set_return ret
	1843	.end_return
	1844	.end
	1845	.namespace [] # revert to root for next test
	1846	.sub join_get_string_returns_a_null_string
	1847	newclass $P0, "Foo5"
	1848	new $P0, 'ResizablePMCArray'
	1849	$P1 = new "Foo5"
2718	1850	push $P0, $P1
2719
2720		~~print "a"~~
2721	1851	join $S0, "", $P0
2722		print "b"
2723		print $S0
2724		print "c\n"
2725		end
	1852	is( $S0, "", 'join: get_string returns a null string' )
2726	1853	.end
2727	1854
2728		.namespace ["Foo"]
	1855	.sub eq_addr_or_ne_addr
	1856	set $S0, "Test"
	1857	set $S1, $S0
2729	1858
2730		.sub get_string :vtable :method
2731		.local string ret
	1859	set $I99, 1
	1860	eq_addr $S1, $S0, OK1
	1861	set $I99, 0
	1862	OK1:
	1863	ok($I99, 'eq_addr/ne_addr')
2732	1864
2733		null ret
2734		.begin_return
2735		.set_return ret
2736		.end_return
2737		.end
2738		CODE
2739		abc
2740		OUTPUT
	1865	set $S1, "Test"
	1866	set $I99, 0
	1867	eq_addr $S1, $S0, BAD2
	1868	set $I99, 1
	1869	BAD2:
	1870	ok($I99, 'eq_addr/ne_addr')
2741	1871
2742		pasm_output_is( <<'CODE', <<'OUTPUT', 'eq_addr/ne_addr' );
2743		set S0, "Test"
2744		set S1, S0
2745		eq_addr S1, S0, OK1
2746		print "not "
2747		OK1: print "ok 1\n"
2748		set S1, "Test"
2749		eq_addr S1, S0, BAD2
2750		branch OK2
2751		BAD2: print "not "
2752		OK2: print "ok 2\n"
	1872	set $I99, 1
	1873	ne_addr $S1, $S0, OK3
	1874	set $I99, 0
	1875	OK3:
	1876	ok($I99, 'eq_addr/ne_addr')
2753	1877
2754		ne_addr S1, S0, OK3
2755		print "not "
2756		OK3: print "ok 3\n"
2757		set S0, S1
2758		ne_addr S1, S0, BAD4
2759		branch OK4
2760		BAD4: print "not "
2761		OK4: print "ok 4\n"
2762		end
2763		CODE
2764		ok 1
2765		ok 2
2766		ok 3
2767		ok 4
2768		OUTPUT
	1878	set $S0, $S1
	1879	set $I99, 0
	1880	ne_addr $S1, $S0, BAD4
	1881	set $I99, 1
	1882	BAD4:
	1883	ok($I99, 'eq_addr/ne_addr')
	1884	.end
2769	1885
2770		pasm_output_is( <<'CODE', <<'OUTPUT', 'if_null_s_ic' );
2771		set S0, "foo"
2772		if_null S0, ERROR
2773		print "ok 1\n"
2774		null S0
2775		if_null S0, OK
2776		ERROR: print "error\n"
2777		end
2778		OK: print "ok 2\n"
2779		end
2780		CODE
2781		ok 1
2782		ok 2
2783		OUTPUT
	1886	.sub test_if_null_s_ic
	1887	set $S0, "foo"
	1888	$I99 = 0
	1889	if_null $S0, ERROR
	1890	$I99 = 1
	1891	ERROR:
	1892	ok($I99, 'if_null s_ic' )
2784	1893
2785		pasm_output_is( <<'CODE', <<'OUTPUT', 'upcase' );
2786		set S0, "abCD012yz\n"
2787		upcase S1, S0
2788		print S1
2789		upcase S0
2790		print S0
2791		end
2792		CODE
2793		ABCD012YZ
2794		ABCD012YZ
2795		OUTPUT
	1894	null $S0
	1895	$I99 = 1
	1896	if_null $S0, OK
	1897	$I99 = 0
	1898	OK:
	1899	ok($I99, 'if_null s_ic' )
	1900	.end
2796	1901
2797		pasm_output_is( <<'CODE', <<'OUTPUT', 'downcase' );
2798		set S0, "ABcd012YZ\n"
2799		downcase S1, S0
2800		print S1
2801		downcase S0
2802		print S0
2803		end
2804		CODE
2805		abcd012yz
2806		abcd012yz
2807		OUTPUT
	1902	.sub test_upcase
	1903	set $S0, "abCD012yz"
	1904	upcase $S1, $S0
	1905	is( $S1, "ABCD012YZ", 'upcase' )
	1906
	1907	upcase $S0
	1908	is( $S0, "ABCD012YZ", 'upcase' )
	1909	.end
2808	1910
2809		pasm_output_is( <<'CODE', <<'OUTPUT', 'titlecase' );
2810		set S0, "aBcd012YZ\n"
2811		titlecase S1, S0
2812		print S1
2813		titlecase S0
2814		print S0
2815		end
2816		CODE
2817		Abcd012yz
2818		Abcd012yz
2819		OUTPUT
	1911	.sub test_downcase
	1912	set $S0, "ABcd012YZ"
	1913	downcase $S1, $S0
	1914	is( $S1, "abcd012yz", 'test_downcase' )
	1915
	1916	downcase $S0
	1917	is( $S0, "abcd012yz", 'test_downcase' )
	1918	.end
2820	1919
2821		pasm_output_is( <<'CODE', ord('a'), '3-param ord, one-character string register, I' );
2822		set S0,"a"
2823		set I1, 0
2824		ord I0,S0,I1
2825		print I0
2826		end
2827		CODE
	1920	.sub test_titlecase
	1921	set $S0, "aBcd012YZ"
	1922	titlecase $S1, $S0
	1923	is( $S1, "Abcd012yz", 'test_titlecase' )
	1924
	1925	titlecase $S0
	1926	is( $S0, "Abcd012yz", 'test_titlecase' )
	1927	.end
2828	1928
2829		pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string, I' );
2830		set ~~I1, 1~~
2831		~~ord I0,"ab",I1~~
2832		~~print I0~~
2833		~~end~~
2834		CODE
	1929	.sub three_param_ord_one_character_string_register_i
	1930	set $S0,"a"
	1931	set $I1, 0
	1932	ord $I0,$S0,$I1
	1933	is( $I0, "97", '3-param ord, one-character string register, I' )
	1934	.end
2835	1935
2836		pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string register, I' );
2837		set I1, 1
2838		set S0,"ab"
2839		ord I0,S0,I1
2840		print I0
2841		end
2842		CODE
	1936	.sub three_param_ord_multi_character_string_i
	1937	set $I1, 1
	1938	ord $I0,"ab",$I1
	1939	is( $I0, "98", '3-param ord, multi-character string, I' )
	1940	.end
2843	1941
2844		pasm_error_output_like( <<'CODE', <<'OUTPUT', '3-param ord, multi-character string, I' );
2845		set I1, 2
2846		ord I0,"ab",I1
2847		print I0
2848		end
2849		CODE
2850		/^Cannot get character past end of string/
2851		OUTPUT
	1942	.sub three_param_ord_multi_character_string_register_i
	1943	set $I1, 1
	1944	set $S0,"ab"
	1945	ord $I0,$S0,$I1
	1946	is( $I0, "98", '3-param ord, multi-character string register, I' )
	1947	.end
2852	1948
2853		pasm_error_output_like( <<'CODE', <<'OUTPUT', '3-param ord, multi-character string, I' );
2854		set I1, 2
2855		set S0,"ab"
2856		ord I0,S0,I1
2857		print I0
2858		end
2859		CODE
2860		/^Cannot get character past end of string/
2861		OUTPUT
	1949	.sub exception_three_param_ord_multi_character_string_i
	1950	push_eh handler
	1951	set $I1, 2
	1952	ord $I0,"ab",$I1
	1953	ok( 0, 'no exception: 3-param ord, multi-character string, I' )
	1954	handler:
	1955	.exception_is( 'Cannot get character past end of string' )
	1956	.end
2862	1957
2863		pasm_output_is( <<'CODE', ord('a'), '3-param ord, one-character string, from end, I' );
2864		set I1, -1
2865		ord I0,"a",I1
2866		print I0
2867		end
2868		CODE
	1958	.sub exception_three_param_ord_multi_character_string_i
	1959	push_eh handler
	1960	set $I1, 2
	1961	set $S0,"ab"
	1962	ord $I0,$S0,$I1
	1963	ok( 0, 'no exception: 3-param ord, multi-character string, I' )
	1964	handler:
	1965	.exception_is( 'Cannot get character past end of string' )
	1966	.end
2869	1967
2870		pasm_output_is( <<'CODE', ord('a'), '3-param ord, one-character string register, from end, I' );
2871		set I1, -1
2872		set S0,"a"
2873		ord I0,S0,I1
2874		print I0
2875		end
2876		CODE
	1968	.sub three_param_ord_one_character_string_from_end_i
	1969	set $I1, -1
	1970	ord $I0,"a",$I1
	1971	is( $I0, "97", '3-param ord, one-character string, from end, I' )
	1972	.end
2877	1973
2878		pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string, from end, I' );
2879		set I1, -1
2880		~~ord I0,"ab",I1~~
2881		~~print I0~~
2882		~~end~~
2883		CODE
	1974	.sub three_param_ord_one_character_string_register_from_end_i
	1975	set $I1, -1
	1976	set $S0,"a"
	1977	ord $I0,$S0,$I1
	1978	is( $I0, "97", '3-param ord, one-character string register, from end, I' )
	1979	.end
2884	1980
2885		pasm_output_is( <<'CODE', ord('b'), '3-param ord, multi-character string register, from end, I' );
2886		set I1, -1
2887		set S0,"ab"
2888		ord I0,S0,I1
2889		print I0
2890		end
2891		CODE
	1981	.sub three_param_ord_multi_character_string_from_end_i
	1982	set $I1, -1
	1983	ord $I0,"ab",$I1
	1984	is( $I0, "98", '3-param ord, multi-character string, from end, I' )
	1985	.end
2892	1986
2893		pasm_error_output_like(
2894		<<'CODE', <<'OUTPUT', '3-param ord, multi-character string register, from end, OOB, I' );
2895		set I1, -3
2896		set S0,"ab"
2897		ord I0,S0,I1
2898		print I0
2899		end
2900		CODE
2901		/^Cannot get character before beginning of string/
2902		OUTPUT
	1987	.sub three_param_ord_multi_character_string_register_from_end_i
	1988	set $I1, -1
	1989	set $S0,"ab"
	1990	ord $I0,$S0,$I1
	1991	is( $I0, "98", '3-param ord, multi-character string register, from end, I' )
	1992	.end
2903	1993
2904		pir_output_is( <<'CODE', <<'OUT', 'more string_to_int' );
2905		.sub 'main' :main
2906		print_as_integer('-4')
2907		print_as_integer('X-4')
2908		print_as_integer('--4')
2909		print_as_integer('+')
2910		print_as_integer('++')
2911		print_as_integer('+2')
2912		print_as_integer(' +3')
2913		print_as_integer('++4')
2914		print_as_integer('+ 5')
2915		print_as_integer('-')
2916		print_as_integer('--56')
2917		print_as_integer(' -+67')
2918		print_as_integer('+-78')
2919		print_as_integer(' -089xyz')
2920		print_as_integer('- 89')
2921		.end
	1994	.sub exception_three_param_ord_multi_character_string_register_from_end_oob_i
	1995	push_eh handler
	1996	set $I1, -3
	1997	set $S0,"ab"
	1998	ord $I0,$S0,$I1
	1999	ok( 0, 'no exception: 3-param ord, multi-character string register, from end, OOB, I' )
	2000	handler:
	2001	.exception_is( 'Cannot get character before beginning of string' )
	2002	.end
2922	2003
2923		.sub 'print_as_integer'
2924		.param string s
2925		$I0 = s
2926		print $I0
2927		print "\n"
2928		.end
2929		CODE
2930		-4
2931		0
2932		0
2933		0
2934		0
2935		2
2936		3
2937		0
2938		0
2939		0
2940		0
2941		0
2942		0
2943		-89
2944		0
2945		OUT
	2004	# Utility method for more_string_to_int
	2005	.sub 'print_as_integer'
	2006	.param string s
	2007	.param string answer
	2008	$I0 = s
	2009	concat $S99, 'string to int: ', s
	2010	is( $I0, answer, $S99 )
	2011	.end
2946	2012
2947		pir_output_is( <<'CODE', <<'OUT', 'constant string and modify-in-situ op (RT #60030)' );
2948		.sub doit
	2013	.sub more_string_to_int
	2014	print_as_integer('-4', "-4")
	2015	print_as_integer('X-4',"0")
	2016	print_as_integer('--4',"0")
	2017	print_as_integer('+',"0")
	2018	print_as_integer('++',"0")
	2019	print_as_integer('+2',"2")
	2020	print_as_integer(' +3',"3")
	2021	print_as_integer('++4',"0")
	2022	print_as_integer('+ 5',"0")
	2023	print_as_integer('-',"0")
	2024	print_as_integer('--56',"0")
	2025	print_as_integer(' -+67',"0")
	2026	print_as_integer('+-78',"0")
	2027	print_as_integer(' -089xyz',"-89")
	2028	print_as_integer('- 89',"0")
	2029	.end
	2030
	2031	# Utility sub for constant_string_and_modify_in_situ_op_rt_bug_60030
	2032	.sub doit_sub_for_but_60030
2949	2033	.param string s
2950	2034	$I0 = index s, '::'
2951		~~say s~~
	2035	is( s, "Foo::Bar", 'bug 60030' )
2952	2036	substr s, $I0, 2, "/"
2953		~~say s~~
	2037	is( s, "Foo/Bar", 'bug 60030' )
2954	2038	collect
2955		~~say s~~
	2039	is( s, "Foo/Bar", 'bug 60030' )
2956	2040	.end
2957
2958		.sub main :main
2959		doit('Foo::Bar')
2960
2961		# repeat to prove that the constant 'Foo::Bar' remains unchanged
2962		doit('Foo::Bar')
	2041	.sub constant_string_and_modify_in_situ_op_rt_bug_60030
	2042
	2043	doit_sub_for_but_60030('Foo::Bar')
	2044	# repeat to prove that the constant 'Foo4::Bar4' remains unchanged
	2045	doit_sub_for_but_60030('Foo::Bar')
2963	2046	.end
2964		~~CODE~~
2965		~~Foo::Bar~~
2966		~~Foo/Bar~~
2967		~~Foo/Bar~~
2968		~~Foo::Bar~~
2969		~~Foo/Bar~~
2970		~~Foo/Bar~~
2971		~~OUT~~
2972	2047
2973		pir_output_is( <<'CODE', <<'OUT', 'Corner cases of numification' );
2974		.sub main :main
2975		say 2147483647.0
2976		say -2147483648.0
	2048	.sub corner_cases_of_numification
	2049	is( 2147483647.0, "2147483647", 'corner cases of numification' )
	2050	is( -2147483648.0, "-2147483648", 'corner cases of numification' )
2977	2051	.end
2978		CODE
2979		2147483647
2980		-2147483648
2981		OUT
2982		pir_output_is( <<'CODE', <<'OUT', 'Non canonical nan and inf' );
2983		.sub main :main
	2052
	2053	.sub non_canonical_nan_and_inf
2984	2054	$N0 = 'nan'
2985		say $N0
	2055	is( $N0, "NaN", 'Non canonical nan and inf' )
	2056
2986	2057	$N0 = 'iNf'
2987		say $N0
	2058	is( $N0, "Inf", 'Non canonical nan and inf' )
	2059
2988	2060	$N0 = 'INFINITY'
2989		say $N0
	2061	is( $N0, "Inf", 'Non canonical nan and inf' )
	2062
2990	2063	$N0 = '-INF'
2991		say $N0
	2064	is( $N0, "-Inf", 'Non canonical nan and inf' )
	2065
2992	2066	$N0 = '-Infinity'
2993		~~say $N0~~
	2067	is( $N0, "-Inf", 'Non canonical nan and inf' )
2994	2068	.end
2995		~~CODE~~
2996		~~NaN~~
2997		~~Inf~~
2998		~~Inf~~
2999		~~-Inf~~
3000		~~-Inf~~
3001		~~OUT~~
3002	2069
	2070	.HLL 'foohll'
	2071	.sub split_hll_mapped
	2072	.include 'test_more.pir'
3003	2073
	2074	.local pmc RSA, fooRSA
	2075	RSA = get_class ['ResizableStringArray']
	2076	fooRSA = subclass ['ResizableStringArray'], 'fooRSA'
3004	2077
	2078	.local pmc interp
	2079	interp = getinterp
	2080	interp.'hll_map'(RSA, fooRSA)
	2081
	2082	.local pmc a
	2083	split a, "a", "afooabara"
	2084
	2085	.local string t
	2086	t = typeof a
	2087	is( t, 'fooRSA', 'split - hll mapped' )
	2088
	2089	.local int n, i
	2090	n = a
	2091	is( n, '5', 'split - hll mapped' )
	2092
	2093	.local string s
	2094	s = a[0]
	2095	is( s, '', 'split - hll mapped' )
	2096	s = a[1]
	2097	is( s, 'foo', 'split - hll mapped' )
	2098	s = a[2]
	2099	is( s, 'b', 'split - hll mapped' )
	2100	s = a[3]
	2101	is( s, 'r', 'split - hll mapped' )
	2102	s = a[4]
	2103	is( s, '', 'split - hll mapped' )
	2104	.end
	2105
3005	2106	# Local Variables:
3006		# mode: ~~cperl~~
	2107	# mode: pir
3007	2108	# cperl-indent-level: 4
3008	2109	# fill-column: 100
3009	2110	# End:
3010		# vim: expandtab shiftwidth=4:
	2111	# vim: expandtab shiftwidth=4 ft=pir :

t/op/arithmetics_pmc.t


1		#!~~perl~~
	1	#! parrot
2	2	# Copyright (C) 2001-2009, Parrot Foundation.
3	3	# $Id$
4	4
5		~~use strict;~~
6		~~use warnings;~~
7		~~use lib qw( . lib ../lib ../../lib );~~
8
9		~~use Test::More;~~
10		~~use Parrot::Test;~~
11
12		~~# test for GMP~~
13		~~use Parrot::Config;~~
14
15	5	=head1 NAME
16	6
17	7	t/op/arithmetics_pmc.t - Arithmetic Ops involving PMCs
…	…
26	16
27	17	=cut
28	18
29		# We don't check BigInt and BigNum ops
30		if ( $PConfig{gmp} ) {
31		plan tests => 68;
32		}
33		else {
34		plan tests => 34;
35		}
	19	.sub main :main
	20	.include 'test_more.pir'
	21	.include "iglobals.pasm"
36	22
	23	plan(68)
37	24
38		# Map vtable method to op
39		my %methods = qw{
40		add add
41		subtract sub
42		multiply mul
43		divide div
	25	# Don't check BigInt or BigNum without gmp
	26	.local pmc interp # a handle to our interpreter object.
	27	interp = getinterp
	28	.local pmc config
	29	config = interp[.IGLOBALS_CONFIG_HASH]
	30	.local int gmp
	31	gmp = config['gmp']
44	32
45		floor_divide fdiv
46		modulus mod
47		pow pow
	33	run_tests_for('Integer')
	34	run_tests_for('Float')
48	35
49		~~bitwise_or bor~~
50		~~bitwise_and band~~
51		~~bitwise_xor bxor~~
	36	if gmp goto do_big_ones
	37	skip( 34, "will not test BigInt or BigNum without gmp" )
	38	goto end
52	39
53		~~bitwise_shr shr~~
54		~~bitwise_shl shl~~
55		~~bitwise_lsr lsr~~
	40	do_big_ones:
	41	run_tests_for('BigInt')
	42	run_tests_for('BigNum')
56	43
57		concatenate concat
	44	end:
	45	.end
58	46
59		logical_or or
60		logical_and and
61		logical_xor xor
62		};
	47	.sub run_tests_for
	48	.param pmc type
	49	test_add(type)
	50	test_divide(type)
	51	test_multiply(type)
	52	test_floor_divide(type)
	53	test_logical_and(type)
	54	test_concatenate(type)
	55	test_logical_xor(type)
	56	test_logical_or(type)
	57	test_bitwise_shr(type)
	58	test_bitwise_or(type)
	59	test_bitwise_shl(type)
	60	test_bitwise_xor(type)
	61	test_modulus(type)
	62	test_pow(type)
	63	test_subtract(type)
	64	test_bitwise_lsr(type)
	65	test_bitwise_and(type)
	66	.end
63	67
64		# XXX Put BigInt and BigNum here
65		my @pmcs = qw{
66		Integer Float
67		};
	68	.sub test_add
	69	.param pmc type
68	70
69		if ($PConfig{gmp}) {
70		push @pmcs, qw{ BigInt BigNum};
71		}
	71	$P0 = new type
	72	$P0 = 40
	73	$P1 = new type
	74	$P1 = 2
	75	$P2 = new type
	76	$P2 = 115200
72	77
73		foreach my $pmc (@pmcs) {
74		while(my($vtable, $op) = each(%methods)) {
	78	$P99 = $P2
75	79
76		# We should generate more tests for all possible combinations
77		pir_output_is( <<"CODE", <<OUTPUT, "Original dest is untouched in $pmc.$vtable " );
78		.sub 'test' :main
79		\$P0 = new '$pmc'
80		\$P0 = 40
81		\$P1 = new '$pmc'
82		\$P1 = 2
83		\$P2 = new '$pmc'
84		\$P2 = 115200
	80	$S0 = "original dest is untouched in add for "
	81	$S1 = type
	82	concat $S0, $S1
85	83
86		~~\$P99 = \$P2~~
87	84	# ignore exceptions
88	85	push_eh done
89		~~$op \$P2, \$P0, \~~$P1
	86	add $P2, $P0, $P1
90	87
91		\$I0 = cmp \$P99, 115200
92		unless \$I0 goto done
93		print " not "
	88	$I0 = cmp $P99, 115200
	89
	90	is( $I0, 0, $S0 )
	91	goto end
	92
94	93	done:
95		say "ok"
	94	ok(1, 'ignoring exceptions')
	95	end:
96	96	.end
97		~~CODE~~
98		ok
99		~~OUTPUT~~
100	97
101		}
102		}
	98	.sub test_divide
	99	.param pmc type
103	100
	101	$P0 = new type
	102	$P0 = 40
	103	$P1 = new type
	104	$P1 = 2
	105	$P2 = new type
	106	$P2 = 115200
	107
	108	$P99 = $P2
	109
	110	$S0 = "original dest is untouched in divide for "
	111	$S1 = type
	112	concat $S0, $S1
	113
	114	# ignore exceptions
	115	push_eh done
	116	div $P2, $P0, $P1
	117
	118	$I0 = cmp $P99, 115200
	119
	120	is( $I0, 0, $S0 )
	121	goto end
	122
	123	done:
	124	ok(1, 'ignoring exceptions')
	125	end:
	126	.end
	127
	128	.sub test_multiply
	129	.param pmc type
	130
	131	$P0 = new type
	132	$P0 = 40
	133	$P1 = new type
	134	$P1 = 2
	135	$P2 = new type
	136	$P2 = 115200
	137
	138	$P99 = $P2
	139
	140	$S0 = "original dest is untouched in multiply for "
	141	$S1 = type
	142	concat $S0, $S1
	143
	144	# ignore exceptions
	145	push_eh done
	146	mul $P2, $P0, $P1
	147
	148	$I0 = cmp $P99, 115200
	149
	150	is( $I0, 0, $S0 )
	151	goto end
	152
	153	done:
	154	ok(1, 'ignoring exceptions')
	155	end:
	156	.end
	157
	158	.sub test_floor_divide
	159	.param pmc type
	160
	161	$P0 = new type
	162	$P0 = 40
	163	$P1 = new type
	164	$P1 = 2
	165	$P2 = new type
	166	$P2 = 115200
	167
	168	$P99 = $P2
	169
	170	$S0 = "original dest is untouched in floor_divide for "
	171	$S1 = type
	172	concat $S0, $S1
	173
	174	# ignore exceptions
	175	push_eh done
	176	fdiv $P2, $P0, $P1
	177
	178	$I0 = cmp $P99, 115200
	179
	180	is( $I0, 0, $S0 )
	181	goto end
	182
	183	done:
	184	ok(1, 'ignoring exceptions')
	185	end:
	186	.end
	187
	188	.sub test_logical_and
	189	.param pmc type
	190
	191	$P0 = new type
	192	$P0 = 40
	193	$P1 = new type
	194	$P1 = 2
	195	$P2 = new type
	196	$P2 = 115200
	197
	198	$P99 = $P2
	199
	200	$S0 = "original dest is untouched in logical_and for "
	201	$S1 = type
	202	concat $S0, $S1
	203
	204	# ignore exceptions
	205	push_eh done
	206	and $P2, $P0, $P1
	207
	208	$I0 = cmp $P99, 115200
	209
	210	is( $I0, 0, $S0 )
	211	goto end
	212
	213	done:
	214	ok(1, 'ignoring exceptions')
	215	end:
	216	.end
	217
	218	.sub test_concatenate
	219	.param pmc type
	220
	221	$P0 = new type
	222	$P0 = 40
	223	$P1 = new type
	224	$P1 = 2
	225	$P2 = new type
	226	$P2 = 115200
	227
	228	$P99 = $P2
	229
	230	$S0 = "original dest is untouched in concatenate for "
	231	$S1 = type
	232	concat $S0, $S1
	233
	234	# ignore exceptions
	235	push_eh done
	236	concat $P2, $P0, $P1
	237
	238	$I0 = cmp $P99, 115200
	239
	240	is( $I0, 0, $S0 )
	241	goto end
	242
	243	done:
	244	ok(1, 'ignoring exceptions')
	245	end:
	246	.end
	247
	248	.sub test_logical_xor
	249	.param pmc type
	250
	251	$P0 = new type
	252	$P0 = 40
	253	$P1 = new type
	254	$P1 = 2
	255	$P2 = new type
	256	$P2 = 115200
	257
	258	$P99 = $P2
	259
	260	$S0 = "original dest is untouched in logical_xor for "
	261	$S1 = type
	262	concat $S0, $S1
	263
	264	# ignore exceptions
	265	push_eh done
	266	xor $P2, $P0, $P1
	267
	268	$I0 = cmp $P99, 115200
	269
	270	is( $I0, 0, $S0 )
	271	goto end
	272
	273	done:
	274	ok(1, 'ignoring exceptions')
	275	end:
	276	.end
	277
	278	.sub test_logical_or
	279	.param pmc type
	280
	281	$P0 = new type
	282	$P0 = 40
	283	$P1 = new type
	284	$P1 = 2
	285	$P2 = new type
	286	$P2 = 115200
	287
	288	$P99 = $P2
	289
	290	$S0 = "original dest is untouched in logical_or for "
	291	$S1 = type
	292	concat $S0, $S1
	293
	294	# ignore exceptions
	295	push_eh done
	296	or $P2, $P0, $P1
	297
	298	$I0 = cmp $P99, 115200
	299
	300	is( $I0, 0, $S0 )
	301	goto end
	302
	303	done:
	304	ok(1, 'ignoring exceptions')
	305	end:
	306	.end
	307
	308	.sub test_bitwise_shr
	309	.param pmc type
	310
	311	$P0 = new type
	312	$P0 = 40
	313	$P1 = new type
	314	$P1 = 2
	315	$P2 = new type
	316	$P2 = 115200
	317
	318	$P99 = $P2
	319
	320	$S0 = "original dest is untouched in bitwise_shr for "
	321	$S1 = type
	322	concat $S0, $S1
	323
	324	# ignore exceptions
	325	push_eh done
	326	shr $P2, $P0, $P1
	327
	328	$I0 = cmp $P99, 115200
	329
	330	is( $I0, 0, $S0 )
	331	goto end
	332
	333	done:
	334	ok(1, 'ignoring exceptions')
	335	end:
	336	.end
	337
	338	.sub test_bitwise_or
	339	.param pmc type
	340
	341	$P0 = new type
	342	$P0 = 40
	343	$P1 = new type
	344	$P1 = 2
	345	$P2 = new type
	346	$P2 = 115200
	347
	348	$P99 = $P2
	349
	350	$S0 = "original dest is untouched in bitwise_or for "
	351	$S1 = type
	352	concat $S0, $S1
	353
	354	# ignore exceptions
	355	push_eh done
	356	bor $P2, $P0, $P1
	357
	358	$I0 = cmp $P99, 115200
	359
	360	is( $I0, 0, $S0 )
	361	goto end
	362
	363	done:
	364	ok(1, 'ignoring exceptions')
	365	end:
	366	.end
	367
	368	.sub test_bitwise_shl
	369	.param pmc type
	370
	371	$P0 = new type
	372	$P0 = 40
	373	$P1 = new type
	374	$P1 = 2
	375	$P2 = new type
	376	$P2 = 115200
	377
	378	$P99 = $P2
	379
	380	$S0 = "original dest is untouched in bitwise_shl for "
	381	$S1 = type
	382	concat $S0, $S1
	383
	384	# ignore exceptions
	385	push_eh done
	386	shl $P2, $P0, $P1
	387
	388	$I0 = cmp $P99, 115200
	389
	390	is( $I0, 0, $S0 )
	391	goto end
	392
	393	done:
	394	ok(1, 'ignoring exceptions')
	395	end:
	396	.end
	397
	398	.sub test_bitwise_xor
	399	.param pmc type
	400
	401	$P0 = new type
	402	$P0 = 40
	403	$P1 = new type
	404	$P1 = 2
	405	$P2 = new type
	406	$P2 = 115200
	407
	408	$P99 = $P2
	409
	410	$S0 = "original dest is untouched in bitwise_xor for "
	411	$S1 = type
	412	concat $S0, $S1
	413
	414	# ignore exceptions
	415	push_eh done
	416	bxor $P2, $P0, $P1
	417
	418	$I0 = cmp $P99, 115200
	419
	420	is( $I0, 0, $S0 )
	421	goto end
	422
	423	done:
	424	ok(1, 'ignoring exceptions')
	425	end:
	426	.end
	427
	428	.sub test_modulus
	429	.param pmc type
	430
	431	$P0 = new type
	432	$P0 = 40
	433	$P1 = new type
	434	$P1 = 2
	435	$P2 = new type
	436	$P2 = 115200
	437
	438	$P99 = $P2
	439
	440	$S0 = "original dest is untouched in modulus for "
	441	$S1 = type
	442	concat $S0, $S1
	443
	444	# ignore exceptions
	445	push_eh done
	446	mod $P2, $P0, $P1
	447
	448	$I0 = cmp $P99, 115200
	449
	450	is( $I0, 0, $S0 )
	451	goto end
	452
	453	done:
	454	ok(1, 'ignoring exceptions')
	455	end:
	456	.end
	457
	458	.sub test_pow
	459	.param pmc type
	460
	461	$P0 = new type
	462	$P0 = 40
	463	$P1 = new type
	464	$P1 = 2
	465	$P2 = new type
	466	$P2 = 115200
	467
	468	$P99 = $P2
	469
	470	$S0 = "original dest is untouched in pow for "
	471	$S1 = type
	472	concat $S0, $S1
	473
	474	# ignore exceptions
	475	push_eh done
	476	pow $P2, $P0, $P1
	477
	478	$I0 = cmp $P99, 115200
	479
	480	is( $I0, 0, $S0 )
	481	goto end
	482
	483	done:
	484	ok(1, 'ignoring exceptions')
	485	end:
	486	.end
	487
	488	.sub test_subtract
	489	.param pmc type
	490
	491	$P0 = new type
	492	$P0 = 40
	493	$P1 = new type
	494	$P1 = 2
	495	$P2 = new type
	496	$P2 = 115200
	497
	498	$P99 = $P2
	499
	500	$S0 = "original dest is untouched in subtract for "
	501	$S1 = type
	502	concat $S0, $S1
	503
	504	# ignore exceptions
	505	push_eh done
	506	sub $P2, $P0, $P1
	507
	508	$I0 = cmp $P99, 115200
	509
	510	is( $I0, 0, $S0 )
	511	goto end
	512
	513	done:
	514	ok(1, 'ignoring exceptions')
	515	end:
	516	.end
	517
	518	.sub test_bitwise_lsr
	519	.param pmc type
	520
	521	$P0 = new type
	522	$P0 = 40
	523	$P1 = new type
	524	$P1 = 2
	525	$P2 = new type
	526	$P2 = 115200
	527
	528	$P99 = $P2
	529
	530	$S0 = "original dest is untouched in bitwise_lsr for "
	531	$S1 = type
	532	concat $S0, $S1
	533
	534	# ignore exceptions
	535	push_eh done
	536	lsr $P2, $P0, $P1
	537
	538	$I0 = cmp $P99, 115200
	539
	540	is( $I0, 0, $S0 )
	541	goto end
	542
	543	done:
	544	ok(1, 'ignoring exceptions')
	545	end:
	546	.end
	547
	548	.sub test_bitwise_and
	549	.param pmc type
	550
	551	$P0 = new type
	552	$P0 = 40
	553	$P1 = new type
	554	$P1 = 2
	555	$P2 = new type
	556	$P2 = 115200
	557
	558	$P99 = $P2
	559
	560	$S0 = "original dest is untouched in bitwise_and for "
	561	$S1 = type
	562	concat $S0, $S1
	563
	564	# ignore exceptions
	565	push_eh done
	566	band $P2, $P0, $P1
	567
	568	$I0 = cmp $P99, 115200
	569
	570	is( $I0, 0, $S0 )
	571	goto end
	572
	573	done:
	574	ok(1, 'ignoring exceptions')
	575	end:
	576	.end
	577
	578	## Perl code used to generate above tests:
	579	# #!/usr/bin/env perl
	580	#
	581	# # We should generate more tests for all possible combinations
	582	# # Map vtable method to op
	583	# my %methods = qw{
	584	# add add
	585	# subtract sub
	586	# multiply mul
	587	# divide div
	588	#
	589	# floor_divide fdiv
	590	# modulus mod
	591	# pow pow
	592	#
	593	# bitwise_or bor
	594	# bitwise_and band
	595	# bitwise_xor bxor
	596	#
	597	# bitwise_shr shr
	598	# bitwise_shl shl
	599	# bitwise_lsr lsr
	600	#
	601	# concatenate concat
	602	#
	603	# logical_or or
	604	# logical_and and
	605	# logical_xor xor
	606	# };
	607	#
	608	# # foreach my $pmc (@pmcs) {
	609	# while(my($vtable, $op) = each(%methods)) {
	610	#
	611	# print <<"END";
	612	# .sub test_$vtable
	613	# .param pmc type
	614	#
	615	# \$P0 = new type
	616	# \$P0 = 40
	617	# \$P1 = new type
	618	# \$P1 = 2
	619	# \$P2 = new type
	620	# \$P2 = 115200
	621	#
	622	# \$P99 = \$P2
	623	#
	624	# \$S0 = "original dest is untouched in $vtable for "
	625	# \$S1 = type
	626	# concat \$S0, \$S1
	627	#
	628	# # ignore exceptions
	629	# push_eh done
	630	# $op \$P2, \$P0, \$P1
	631	#
	632	# \$I0 = cmp \$P99, 115200
	633	#
	634	# is( \$I0, 0, \$S0 )
	635	# goto end
	636	#
	637	# done:
	638	# ok(1, 'ignoring exceptions')
	639	# end:
	640	# .end
	641	#
	642	# END
	643	#
	644	# }
	645
104	646	# Local Variables:
105		# mode: ~~cperl~~
	647	# mode: pir
106	648	# cperl-indent-level: 4
107	649	# fill-column: 100
108	650	# End:
109		# vim: expandtab shiftwidth=4:
	651	# vim: expandtab shiftwidth=4 ft=pir :

t/op/64bit.t


1		#!~~perl~~
2		# Copyright (C) 2001-2005, Parrot Foundation.
	1	#! parrot
	2	# Copyright (C) 2001-2009, Parrot Foundation.
3	3	# $Id$
4	4
5		~~use strict;~~
6		~~use warnings;~~
7		~~use lib qw( . lib ../lib ../../lib );~~
8		~~use Test::More;~~
9		~~use Parrot::Test;~~
10		~~use Parrot::Config;~~
11
12	5	=head1 NAME
13	6
14	7	t/op/64bit.t - Testing integer ops on 64-bit platforms
…	…
24	17
25	18	=cut
26	19
27		## remember to change the number of tests :-)
28		if ( $PConfig{intvalsize} == 8 ) {
29		plan tests => 1;
30		}
31		else {
32		plan skip_all => "64bit INTVAL platforms only";
33		}
	20	.sub main :main
	21	.include "iglobals.pasm"
	22	.include 'test_more.pir'
34	23
35		pasm_output_is( <<'CODE', <<'OUTPUT', "bitops64" );
	24	# Check to see if this is 64 bit
	25	.local pmc interp # a handle to our interpreter object.
	26	interp = getinterp
	27	.local pmc config
	28	config = interp[.IGLOBALS_CONFIG_HASH]
	29	.local int intvalsize
	30	intvalsize = config['intvalsize']
	31
	32	plan(5)
	33
	34	if intvalsize == 8 goto is_64_bit
	35	skip(5, "this is not a 64 bit platform")
	36	goto end
	37
	38	is_64_bit:
	39	bitops64()
	40
	41	end:
	42	.end
	43
	44
	45	.sub bitops64
36	46	# check bitops for 8-byte ints
37		~~set I0, 0xffffffffffffffff~~
38		~~print I0 # -1~~
39		~~print "\n"~~
40		~~set I1, 0x00000000ffffffff~~
41		~~print I1 # 4294967295~~
42		~~print "\n"~~
43		~~set I0, I1~~
44		~~shl I0, I0, 32~~
45		~~print I0 # -4294967296~~
46		~~print "\n"~~
47		~~band I2, I0, I1~~
48		~~print I2 # 0~~
49		~~print "\n"~~
50		~~bor I2, I0, I1~~
51		~~print I2 # -1~~
52		~~print "\n"~~
53		~~end~~
54	47
55		CODE
56		-1
57		4294967295
58		-4294967296
59		0
60		-1
61		OUTPUT
	48	set $I0, 0xffffffffffffffff
	49	is( $I0, -1, 'bitops64' )
	50
	51	set $I1, 0x00000000ffffffff
	52	is( $I1, 4294967295, 'bitops64' )
	53
	54	set $I0, $I1
	55	shl $I0, $I0, 32
	56	is( $I0, -4294967296, 'bitops64' )
	57
	58	band $I2, $I0, $I1
	59	is( $I2, 0, 'bitops64' )
62	60
	61	bor $I2, $I0, $I1
	62	is( $I2, -1, 'bitops64' )
	63	.end
	64
63	65	# Local Variables:
64		# mode: ~~cperl~~
	66	# mode: pir
65	67	# cperl-indent-level: 4
66	68	# fill-column: 100
67	69	# End:
68		# vim: expandtab shiftwidth=4:
	70	# vim: expandtab shiftwidth=4 ft=pir:

t/op/string_cmp.t


	1	#! parrot
	2	# Copyright (C) 2001-2009, Parrot Foundation.
	3	# $Id: string.t 41325 2009-09-17 19:39:19Z NotFound $
	4
	5	=head1 NAME
	6
	7	t/op/string.t - Parrot Strings
	8
	9	=head1 SYNOPSIS
	10
	11	% prove t/op/string.t
	12
	13	=head1 DESCRIPTION
	14
	15	Tests Parrot string registers and operations.
	16
	17	=cut
	18
	19	.sub main :main
	20	.include 'test_more.pir'
	21
	22	plan(24)
	23
	24	test_eq_s_s_ic()
	25	test_eq_sc_s_ic()
	26	test_eq_s_sc_ic()
	27	test_eq_sc_sc_ic()
	28	test_ne_s_s_ic()
	29	test_ne_sc_s_ic()
	30	test_ne_s_sc_ic()
	31	test_ne_sc_sc_ic()
	32	test_lt_s_s_ic()
	33	test_lt_sc_s_ic()
	34	test_lt_s_sc_ic()
	35	test_lt_sc_sc_ic()
	36	test_le_s_s_ic()
	37	test_le_sc_s_ic()
	38	test_le_s_sc_ic()
	39	test_le_sc_sc_ic()
	40	test_gt_s_s_ic()
	41	test_gt_sc_s_ic()
	42	test_gt_s_sc_ic()
	43	test_gt_sc_sc_ic()
	44	test_ge_s_s_ic()
	45	test_ge_sc_s_ic()
	46	test_ge_s_sc_ic()
	47	test_ge_sc_sc_ic()
	48
	49	.end
	50
	51	.sub test_eq_s_s_ic
	52	set $S0, "hello"
	53	set $S1, "hello"
	54	eq $S0, $S1, OK1
	55	branch ERROR
	56	OK1:
	57	set $S0, "hello"
	58	set $S1, "world"
	59	eq $S0, $S1, ERROR
	60	OK2:
	61	set $S0, "world"
	62	set $S1, "hello"
	63	eq $S0, $S1, ERROR
	64	OK3:
	65	set $S0, "hello"
	66	set $S1, "hellooo"
	67	eq $S0, $S1, ERROR
	68	OK4:
	69	set $S0, "hellooo"
	70	set $S1, "hello"
	71	eq $S0, $S1, ERROR
	72	OK5:
	73	set $S0, "hello"
	74	set $S1, "hella"
	75	eq $S0, $S1, ERROR
	76	OK6:
	77	set $S0, "hella"
	78	set $S1, "hello"
	79	eq $S0, $S1, ERROR
	80	OK7:
	81	set $S0, "hella"
	82	set $S1, "hellooo"
	83	eq $S0, $S1, ERROR
	84	OK8:
	85	set $S0, "hellooo"
	86	set $S1, "hella"
	87	eq $S0, $S1, ERROR
	88	OK9:
	89	set $S0, "hElLo"
	90	set $S1, "HeLlO"
	91	eq $S0, $S1, ERROR
	92	OK10:
	93	set $S0, "hElLo"
	94	set $S1, "hElLo"
	95	eq $S0, $S1, OK11
	96	branch ERROR
	97	OK11:
	98	ok( 1, 'eq_s_s_ic' )
	99	goto END
	100	ERROR:
	101	ok( 0, 'eq_s_s_ic' )
	102	END:
	103	.end
	104
	105	.sub test_eq_sc_s_ic
	106	set $S0, "hello"
	107	eq "hello", $S0, OK1
	108	branch ERROR
	109	OK1:
	110	set $S0, "world"
	111	eq "hello", $S0, ERROR
	112	OK2:
	113	set $S0, "hello"
	114	eq "world", $S0, ERROR
	115	OK3:
	116	set $S0, "hellooo"
	117	eq "hello", $S0, ERROR
	118	OK4:
	119	set $S0, "hello"
	120	eq "hellooo", $S0, ERROR
	121	OK5:
	122	set $S0, "hella"
	123	eq "hello", $S0, ERROR
	124	OK6:
	125	set $S0, "hello"
	126	eq "hella", $S0, ERROR
	127	OK7:
	128	set $S0, "hellooo"
	129	eq "hella", $S0, ERROR
	130	OK8:
	131	set $S0, "hella"
	132	eq "hellooo", $S0, ERROR
	133	OK9:
	134	set $S0, "HeLlO"
	135	eq "hElLo", $S0, ERROR
	136	OK10:
	137	set $S0, "hElLo"
	138	eq "hElLo", $S0, OK11
	139	branch ERROR
	140	OK11:
	141	ok( 1, 'eq_sc_s_ic' )
	142	goto END
	143	ERROR:
	144	ok( 0, 'eq_sc_s_ic' )
	145	END:
	146	.end
	147
	148	.sub test_eq_s_sc_ic
	149	set $S0, "hello"
	150	eq $S0, "hello", OK1
	151	branch ERROR
	152	OK1:
	153	set $S0, "hello"
	154	eq $S0, "world", ERROR
	155	OK2:
	156	set $S0, "world"
	157	eq $S0, "hello", ERROR
	158	OK3:
	159	set $S0, "hello"
	160	eq $S0, "hellooo", ERROR
	161	OK4:
	162	set $S0, "hellooo"
	163	eq $S0, "hello", ERROR
	164	OK5:
	165	set $S0, "hello"
	166	eq $S0, "hella", ERROR
	167	OK6:
	168	set $S0, "hella"
	169	eq $S0, "hello", ERROR
	170	OK7:
	171	set $S0, "hella"
	172	eq $S0, "hellooo", ERROR
	173	OK8:
	174	set $S0, "hellooo"
	175	eq $S0, "hella", ERROR
	176	OK9:
	177	set $S0, "hElLo"
	178	eq $S0, "HeLlO", ERROR
	179	OK10:
	180	set $S0, "hElLo"
	181	eq $S0, "hElLo", OK11
	182	branch ERROR
	183	OK11:
	184	ok( 1, 'eq_s_sc_ic' )
	185	goto END
	186	ERROR:
	187	ok( 0, 'eq_s_sc_ic' )
	188	END:
	189	.end
	190
	191	.sub test_eq_sc_sc_ic
	192	eq "hello", "hello", OK1
	193	branch ERROR
	194	OK1:
	195	eq "hello", "world", ERROR
	196	OK2:
	197	eq "world", "hello", ERROR
	198	OK3:
	199	eq "hello", "hellooo", ERROR
	200	OK4:
	201	eq "hellooo", "hello", ERROR
	202	OK5:
	203	eq "hello", "hella", ERROR
	204	OK6:
	205	eq "hella", "hello", ERROR
	206	OK7:
	207	eq "hella", "hellooo", ERROR
	208	OK8:
	209	eq "hellooo", "hella", ERROR
	210	OK9:
	211	eq "hElLo", "HeLlO", ERROR
	212	OK10:
	213	eq "hElLo", "hElLo", OK11
	214	branch ERROR
	215	OK11:
	216	ok( 1, 'eq_sc_sc_ic' )
	217	goto END
	218	ERROR:
	219	ok( 0, 'eq_sc_sc_ic' )
	220	END:
	221	.end
	222
	223	.sub test_ne_s_s_ic
	224	set $S0, "hello"
	225	set $S1, "hello"
	226	ne $S0, $S1, ERROR
	227	OK1:
	228	set $S0, "hello"
	229	set $S1, "world"
	230	ne $S0, $S1, OK2
	231	branch ERROR
	232	OK2:
	233	set $S0, "world"
	234	set $S1, "hello"
	235	ne $S0, $S1, OK3
	236	branch ERROR
	237	OK3:
	238	set $S0, "hello"
	239	set $S1, "hellooo"
	240	ne $S0, $S1, OK4
	241	branch ERROR
	242	OK4:
	243	set $S0, "hellooo"
	244	set $S1, "hello"
	245	ne $S0, $S1, OK5
	246	branch ERROR
	247	OK5:
	248	set $S0, "hello"
	249	set $S1, "hella"
	250	ne $S0, $S1, OK6
	251	branch ERROR
	252	OK6:
	253	set $S0, "hella"
	254	set $S1, "hello"
	255	ne $S0, $S1, OK7
	256	branch ERROR
	257	OK7:
	258	set $S0, "hella"
	259	set $S1, "hellooo"
	260	ne $S0, $S1, OK8
	261	branch ERROR
	262	OK8:
	263	set $S0, "hellooo"
	264	set $S1, "hella"
	265	ne $S0, $S1, OK9
	266	branch ERROR
	267	OK9:
	268	set $S0, "hElLo"
	269	set $S1, "HeLlO"
	270	ne $S0, $S1, OK10
	271	branch ERROR
	272	OK10:
	273	set $S0, "hElLo"
	274	set $S1, "hElLo"
	275	ne $S0, $S1, ERROR
	276	OK11:
	277	ok( 1, 'ne_s_s_ic' )
	278	goto END
	279	ERROR:
	280	ok( 0, 'ne_s_s_ic' )
	281	END:
	282	.end
	283
	284	.sub test_ne_sc_s_ic
	285	set $S0, "hello"
	286	ne "hello", $S0, ERROR
	287	OK1:
	288	set $S0, "world"
	289	ne "hello", $S0, OK2
	290	branch ERROR
	291	OK2:
	292	set $S0, "hello"
	293	ne "world", $S0, OK3
	294	branch ERROR
	295	OK3:
	296	set $S0, "hellooo"
	297	ne "hello", $S0, OK4
	298	branch ERROR
	299	OK4:
	300	set $S0, "hello"
	301	ne "hellooo", $S0, OK5
	302	branch ERROR
	303	OK5:
	304	set $S0, "hella"
	305	ne "hello", $S0, OK6
	306	branch ERROR
	307	OK6:
	308	set $S0, "hello"
	309	ne "hella", $S0, OK7
	310	branch ERROR
	311	OK7:
	312	set $S0, "hellooo"
	313	ne "hella", $S0, OK8
	314	branch ERROR
	315	OK8:
	316	set $S0, "hella"
	317	ne "hellooo", $S0, OK9
	318	branch ERROR
	319	OK9:
	320	set $S0, "HeLlO"
	321	ne "hElLo", $S0, OK10
	322	branch ERROR
	323	OK10:
	324	set $S0, "hElLo"
	325	ne "hElLo", $S0, ERROR
	326	OK11:
	327	ok( 1, 'ne_sc_s_ic' )
	328	goto END
	329	ERROR:
	330	ok( 0, 'ne_sc_s_ic' )
	331	END:
	332	.end
	333
	334	.sub test_ne_s_sc_ic
	335	set $S0, "hello"
	336	ne $S0, "hello", ERROR
	337	OK1:
	338	set $S0, "hello"
	339	ne $S0, "world", OK2
	340	branch ERROR
	341	OK2:
	342	set $S0, "world"
	343	ne $S0, "hello", OK3
	344	branch ERROR
	345	OK3:
	346	set $S0, "hello"
	347	ne $S0, "hellooo", OK4
	348	branch ERROR
	349	OK4:
	350	set $S0, "hellooo"
	351	ne $S0, "hello", OK5
	352	branch ERROR
	353	OK5:
	354	set $S0, "hello"
	355	ne $S0, "hella", OK6
	356	branch ERROR
	357	OK6:
	358	set $S0, "hella"
	359	ne $S0, "hello", OK7
	360	branch ERROR
	361	OK7:
	362	set $S0, "hella"
	363	ne $S0, "hellooo", OK8
	364	branch ERROR
	365	OK8:
	366	set $S0, "hellooo"
	367	ne $S0, "hella", OK9
	368	branch ERROR
	369	OK9:
	370	set $S0, "hElLo"
	371	ne $S0, "HeLlO", OK10
	372	branch ERROR
	373	OK10:
	374	set $S0, "hElLo"
	375	ne $S0, "hElLo", ERROR
	376	OK11:
	377	ok( 1, 'ne_s_sc_ic' )
	378	goto END
	379	ERROR:
	380	ok( 0, 'ne_s_sc_ic' )
	381	END:
	382	.end
	383
	384	.sub test_ne_sc_sc_ic
	385	ne "hello", "hello", ERROR
	386	OK1:
	387	ne "hello", "world", OK2
	388	branch ERROR
	389	OK2:
	390	ne "world", "hello", OK3
	391	branch ERROR
	392	OK3:
	393	ne "hello", "hellooo", OK4
	394	branch ERROR
	395	OK4:
	396	ne "hellooo", "hello", OK5
	397	branch ERROR
	398	OK5:
	399	ne "hello", "hella", OK6
	400	branch ERROR
	401	OK6:
	402	ne "hella", "hello", OK7
	403	branch ERROR
	404	OK7:
	405	ne "hella", "hellooo", OK8
	406	branch ERROR
	407	OK8:
	408	ne "hellooo", "hella", OK9
	409	branch ERROR
	410	OK9:
	411	ne "hElLo", "HeLlO", OK10
	412	branch ERROR
	413	OK10:
	414	ne "hElLo", "hElLo", ERROR
	415	OK11:
	416	ok( 1, 'ne_sc_sc_ic' )
	417	goto END
	418	ERROR:
	419	ok( 0, 'ne_sc_sc_ic' )
	420	END:
	421	.end
	422
	423	.sub test_lt_s_s_ic
	424	set $S0, "hello"
	425	set $S1, "hello"
	426	lt $S0, $S1, ERROR
	427	OK1:
	428	set $S0, "hello"
	429	set $S1, "world"
	430	lt $S0, $S1, OK2
	431	branch ERROR
	432	OK2:
	433	set $S0, "world"
	434	set $S1, "hello"
	435	lt $S0, $S1, ERROR
	436	OK3:
	437	set $S0, "hello"
	438	set $S1, "hellooo"
	439	lt $S0, $S1, OK4
	440	branch ERROR
	441	OK4:
	442	set $S0, "hellooo"
	443	set $S1, "hello"
	444	lt $S0, $S1, ERROR
	445	OK5:
	446	set $S0, "hello"
	447	set $S1, "hella"
	448	lt $S0, $S1, ERROR
	449	OK6:
	450	set $S0, "hella"
	451	set $S1, "hello"
	452	lt $S0, $S1, OK7
	453	branch ERROR
	454	OK7:
	455	set $S0, "hella"
	456	set $S1, "hellooo"
	457	lt $S0, $S1, OK8
	458	branch ERROR
	459	OK8:
	460	set $S0, "hellooo"
	461	set $S1, "hella"
	462	lt $S0, $S1, ERROR
	463	OK9:
	464	set $S0, "hElLo"
	465	set $S1, "HeLlO"
	466	lt $S0, $S1, ERROR
	467	OK10:
	468	set $S0, "hElLo"
	469	set $S1, "hElLo"
	470	lt $S0, $S1, ERROR
	471	OK11:
	472	ok( 1, 'lt_s_s_ic' )
	473	goto END
	474	ERROR:
	475	ok( 0, 'lt_s_s_ic' )
	476	END:
	477	.end
	478
	479	.sub test_lt_sc_s_ic
	480	set $S0, "hello"
	481	lt "hello", $S0, ERROR
	482	OK1:
	483	set $S0, "world"
	484	lt "hello", $S0, OK2
	485	branch ERROR
	486	OK2:
	487	set $S0, "hello"
	488	lt "world", $S0, ERROR
	489	OK3:
	490	set $S0, "hellooo"
	491	lt "hello", $S0, OK4
	492	branch ERROR
	493	OK4:
	494	set $S0, "hello"
	495	lt "hellooo", $S0, ERROR
	496	OK5:
	497	set $S0, "hella"
	498	lt "hello", $S0, ERROR
	499	OK6:
	500	set $S0, "hello"
	501	lt "hella", $S0, OK7
	502	branch ERROR
	503	OK7:
	504	set $S0, "hellooo"
	505	lt "hella", $S0, OK8
	506	branch ERROR
	507	OK8:
	508	set $S0, "hella"
	509	lt "hellooo", $S0, ERROR
	510	OK9:
	511	set $S0, "HeLlO"
	512	lt "hElLo", $S0, ERROR
	513	OK10:
	514	set $S0, "hElLo"
	515	lt "hElLo", $S0, ERROR
	516	OK11:
	517	ok( 1, 'lt_sc_s_ic' )
	518	goto END
	519	ERROR:
	520	ok( 0, 'lt_sc_s_ic' )
	521	END:
	522	.end
	523
	524	.sub test_lt_s_sc_ic
	525	set $S0, "hello"
	526	lt $S0, "hello", ERROR
	527	OK1:
	528	set $S0, "hello"
	529	lt $S0, "world", OK2
	530	branch ERROR
	531	OK2:
	532	set $S0, "world"
	533	lt $S0, "hello", ERROR
	534	OK3:
	535	set $S0, "hello"
	536	lt $S0, "hellooo", OK4
	537	branch ERROR
	538	OK4:
	539	set $S0, "hellooo"
	540	lt $S0, "hello", ERROR
	541	OK5:
	542	set $S0, "hello"
	543	lt $S0, "hella", ERROR
	544	OK6:
	545	set $S0, "hella"
	546	lt $S0, "hello", OK7
	547	branch ERROR
	548	OK7:
	549	set $S0, "hella"
	550	lt $S0, "hellooo", OK8
	551	branch ERROR
	552	OK8:
	553	set $S0, "hellooo"
	554	lt $S0, "hella", ERROR
	555	OK9:
	556	set $S0, "hElLo"
	557	lt $S0, "HeLlO", ERROR
	558	OK10:
	559	set $S0, "hElLo"
	560	lt $S0, "hElLo", ERROR
	561	OK11:
	562	ok( 1, 'lt_s_sc_ic' )
	563	goto END
	564	ERROR:
	565	ok( 0, 'lt_s_sc_ic' )
	566	END:
	567	.end
	568
	569	.sub test_lt_sc_sc_ic
	570	lt "hello", "hello", ERROR
	571	OK1:
	572	lt "hello", "world", OK2
	573	branch ERROR
	574	OK2:
	575	lt "world", "hello", ERROR
	576	OK3:
	577	lt "hello", "hellooo", OK4
	578	branch ERROR
	579	OK4:
	580	lt "hellooo", "hello", ERROR
	581	OK5:
	582	lt "hello", "hella", ERROR
	583	OK6:
	584	lt "hella", "hello", OK7
	585	branch ERROR
	586	OK7:
	587	lt "hella", "hellooo", OK8
	588	branch ERROR
	589	OK8:
	590	lt "hellooo", "hella", ERROR
	591	OK9:
	592	lt "hElLo", "HeLlO", ERROR
	593	OK10:
	594	lt "hElLo", "hElLo", ERROR
	595	OK11:
	596	ok( 1, 'lt_sc_sc_ic' )
	597	goto END
	598	ERROR:
	599	ok( 0, 'lt_sc_sc_ic' )
	600	END:
	601	.end
	602
	603	.sub test_le_s_s_ic
	604	set $S0, "hello"
	605	set $S1, "hello"
	606	le $S0, $S1, OK1
	607	branch ERROR
	608	OK1:
	609	set $S0, "hello"
	610	set $S1, "world"
	611	le $S0, $S1, OK2
	612	branch ERROR
	613	OK2:
	614	set $S0, "world"
	615	set $S1, "hello"
	616	le $S0, $S1, ERROR
	617	OK3:
	618	set $S0, "hello"
	619	set $S1, "hellooo"
	620	le $S0, $S1, OK4
	621	branch ERROR
	622	OK4:
	623	set $S0, "hellooo"
	624	set $S1, "hello"
	625	le $S0, $S1, ERROR
	626	OK5:
	627	set $S0, "hello"
	628	set $S1, "hella"
	629	le $S0, $S1, ERROR
	630	OK6:
	631	set $S0, "hella"
	632	set $S1, "hello"
	633	le $S0, $S1, OK7
	634	branch ERROR
	635	OK7:
	636	set $S0, "hella"
	637	set $S1, "hellooo"
	638	le $S0, $S1, OK8
	639	branch ERROR
	640	OK8:
	641	set $S0, "hellooo"
	642	set $S1, "hella"
	643	le $S0, $S1, ERROR
	644	OK9:
	645	set $S0, "hElLo"
	646	set $S1, "HeLlO"
	647	le $S0, $S1, ERROR
	648	OK10:
	649	set $S0, "hElLo"
	650	set $S1, "hElLo"
	651	le $S0, $S1, OK11
	652	branch ERROR
	653	OK11:
	654	ok( 1, 'le_s_s_ic' )
	655	goto END
	656	ERROR:
	657	ok( 0, 'le_s_s_ic' )
	658	END:
	659	.end
	660
	661	.sub test_le_sc_s_ic
	662	set $S0, "hello"
	663	le "hello", $S0, OK1
	664	branch ERROR
	665	OK1:
	666	set $S0, "world"
	667	le "hello", $S0, OK2
	668	branch ERROR
	669	OK2:
	670	set $S0, "hello"
	671	le "world", $S0, ERROR
	672	OK3:
	673	set $S0, "hellooo"
	674	le "hello", $S0, OK4
	675	branch ERROR
	676	OK4:
	677	set $S0, "hello"
	678	le "hellooo", $S0, ERROR
	679	OK5:
	680	set $S0, "hella"
	681	le "hello", $S0, ERROR
	682	OK6:
	683	set $S0, "hello"
	684	le "hella", $S0, OK7
	685	branch ERROR
	686	OK7:
	687	set $S0, "hellooo"
	688	le "hella", $S0, OK8
	689	branch ERROR
	690	OK8:
	691	set $S0, "hella"
	692	le "hellooo", $S0, ERROR
	693	OK9:
	694	set $S0, "HeLlO"
	695	le "hElLo", $S0, ERROR
	696	OK10:
	697	set $S0, "hElLo"
	698	le "hElLo", $S0, OK11
	699	branch ERROR
	700	OK11:
	701	ok( 1, 'le_sc_s_ic' )
	702	goto END
	703	ERROR:
	704	ok( 0, 'le_sc_s_ic' )
	705	END:
	706	.end
	707
	708	.sub test_le_s_sc_ic
	709	set $S0, "hello"
	710	le $S0, "hello", OK1
	711	branch ERROR
	712	OK1:
	713	set $S0, "hello"
	714	le $S0, "world", OK2
	715	branch ERROR
	716	OK2:
	717	set $S0, "world"
	718	le $S0, "hello", ERROR
	719	OK3:
	720	set $S0, "hello"
	721	le $S0, "hellooo", OK4
	722	branch ERROR
	723	OK4:
	724	set $S0, "hellooo"
	725	le $S0, "hello", ERROR
	726	OK5:
	727	set $S0, "hello"
	728	le $S0, "hella", ERROR
	729	OK6:
	730	set $S0, "hella"
	731	le $S0, "hello", OK7
	732	branch ERROR
	733	OK7:
	734	set $S0, "hella"
	735	le $S0, "hellooo", OK8
	736	branch ERROR
	737	OK8:
	738	set $S0, "hellooo"
	739	le $S0, "hella", ERROR
	740	OK9:
	741	set $S0, "hElLo"
	742	le $S0, "HeLlO", ERROR
	743	OK10:
	744	set $S0, "hElLo"
	745	le $S0, "hElLo", OK11
	746	branch ERROR
	747	OK11:
	748	ok( 1, 'le_s_sc_ic' )
	749	goto END
	750	ERROR:
	751	ok( 0, 'le_s_sc_ic' )
	752	END:
	753	.end
	754
	755	.sub test_le_sc_sc_ic
	756	le "hello", "hello", OK1
	757	branch ERROR
	758	OK1:
	759	le "hello", "world", OK2
	760	branch ERROR
	761	OK2:
	762	le "world", "hello", ERROR
	763	OK3:
	764	le "hello", "hellooo", OK4
	765	branch ERROR
	766	OK4:
	767	le "hellooo", "hello", ERROR
	768	OK5:
	769	le "hello", "hella", ERROR
	770	OK6:
	771	le "hella", "hello", OK7
	772	branch ERROR
	773	OK7:
	774	le "hella", "hellooo", OK8
	775	branch ERROR
	776	OK8:
	777	le "hellooo", "hella", ERROR
	778	OK9:
	779	le "hElLo", "HeLlO", ERROR
	780	OK10:
	781	le "hElLo", "hElLo", OK11
	782	branch ERROR
	783	OK11:
	784	ok( 1, 'le_sc_sc_ic' )
	785	goto END
	786	ERROR:
	787	ok( 0, 'le_sc_sc_ic' )
	788	END:
	789	.end
	790
	791	.sub test_gt_s_s_ic
	792	set $S0, "hello"
	793	set $S1, "hello"
	794	gt $S0, $S1, ERROR
	795	OK1:
	796	set $S0, "hello"
	797	set $S1, "world"
	798	gt $S0, $S1, ERROR
	799	OK2:
	800	set $S0, "world"
	801	set $S1, "hello"
	802	gt $S0, $S1, OK3
	803	branch ERROR
	804	OK3:
	805	set $S0, "hello"
	806	set $S1, "hellooo"
	807	gt $S0, $S1, ERROR
	808	OK4:
	809	set $S0, "hellooo"
	810	set $S1, "hello"
	811	gt $S0, $S1, OK5
	812	branch ERROR
	813	OK5:
	814	set $S0, "hello"
	815	set $S1, "hella"
	816	gt $S0, $S1, OK6
	817	branch ERROR
	818	OK6:
	819	set $S0, "hella"
	820	set $S1, "hello"
	821	gt $S0, $S1, ERROR
	822	OK7:
	823	set $S0, "hella"
	824	set $S1, "hellooo"
	825	gt $S0, $S1, ERROR
	826	OK8:
	827	set $S0, "hellooo"
	828	set $S1, "hella"
	829	gt $S0, $S1, OK9
	830	branch ERROR
	831	OK9:
	832	set $S0, "hElLo"
	833	set $S1, "HeLlO"
	834	gt $S0, $S1, OK10
	835	branch ERROR
	836	OK10:
	837	set $S0, "hElLo"
	838	set $S1, "hElLo"
	839	gt $S0, $S1, ERROR
	840	OK11:
	841	ok( 1, 'gt_s_s_ic' )
	842	goto END
	843	ERROR:
	844	ok( 0, 'gt_s_s_ic' )
	845	END:
	846	.end
	847
	848	.sub test_gt_sc_s_ic
	849	set $S0, "hello"
	850	gt "hello", $S0, ERROR
	851	OK1:
	852	set $S0, "world"
	853	gt "hello", $S0, ERROR
	854	OK2:
	855	set $S0, "hello"
	856	gt "world", $S0, OK3
	857	branch ERROR
	858	OK3:
	859	set $S0, "hellooo"
	860	gt "hello", $S0, ERROR
	861	OK4:
	862	set $S0, "hello"
	863	gt "hellooo", $S0, OK5
	864	branch ERROR
	865	OK5:
	866	set $S0, "hella"
	867	gt "hello", $S0, OK6
	868	branch ERROR
	869	OK6:
	870	set $S0, "hello"
	871	gt "hella", $S0, ERROR
	872	OK7:
	873	set $S0, "hellooo"
	874	gt "hella", $S0, ERROR
	875	OK8:
	876	set $S0, "hella"
	877	gt "hellooo", $S0, OK9
	878	branch ERROR
	879	OK9:
	880	set $S0, "HeLlO"
	881	gt "hElLo", $S0, OK10
	882	branch ERROR
	883	OK10:
	884	set $S0, "hElLo"
	885	gt "hElLo", $S0, ERROR
	886	OK11:
	887	ok( 1, 'gt_sc_s_ic' )
	888	goto END
	889	ERROR:
	890	ok( 0, 'gt_sc_s_ic' )
	891	END:
	892	.end
	893
	894	.sub test_gt_s_sc_ic
	895	set $S0, "hello"
	896	gt $S0, "hello", ERROR
	897	OK1:
	898	set $S0, "hello"
	899	gt $S0, "world", ERROR
	900	OK2:
	901	set $S0, "world"
	902	gt $S0, "hello", OK3
	903	branch ERROR
	904	OK3:
	905	set $S0, "hello"
	906	gt $S0, "hellooo", ERROR
	907	OK4:
	908	set $S0, "hellooo"
	909	gt $S0, "hello", OK5
	910	branch ERROR
	911	OK5:
	912	set $S0, "hello"
	913	gt $S0, "hella", OK6
	914	branch ERROR
	915	OK6:
	916	set $S0, "hella"
	917	gt $S0, "hello", ERROR
	918	OK7:
	919	set $S0, "hella"
	920	gt $S0, "hellooo", ERROR
	921	OK8:
	922	set $S0, "hellooo"
	923	gt $S0, "hella", OK9
	924	branch ERROR
	925	OK9:
	926	set $S0, "hElLo"
	927	gt $S0, "HeLlO", OK10
	928	branch ERROR
	929	OK10:
	930	set $S0, "hElLo"
	931	gt $S0, "hElLo", ERROR
	932	OK11:
	933	ok( 1, 'gt_s_sc_ic' )
	934	goto END
	935	ERROR:
	936	ok( 0, 'gt_s_sc_ic' )
	937	END:
	938	.end
	939
	940	.sub test_gt_sc_sc_ic
	941	gt "hello", "hello", ERROR
	942	OK1:
	943	gt "hello", "world", ERROR
	944	OK2:
	945	gt "world", "hello", OK3
	946	branch ERROR
	947	OK3:
	948	gt "hello", "hellooo", ERROR
	949	OK4:
	950	gt "hellooo", "hello", OK5
	951	branch ERROR
	952	OK5:
	953	gt "hello", "hella", OK6
	954	branch ERROR
	955	OK6:
	956	gt "hella", "hello", ERROR
	957	OK7:
	958	gt "hella", "hellooo", ERROR
	959	OK8:
	960	gt "hellooo", "hella", OK9
	961	branch ERROR
	962	OK9:
	963	gt "hElLo", "HeLlO", OK10
	964	branch ERROR
	965	OK10:
	966	gt "hElLo", "hElLo", ERROR
	967	OK11:
	968	ok( 1, 'gt_sc_sc_ic' )
	969	goto END
	970	ERROR:
	971	ok( 0, 'gt_sc_sc_ic' )
	972	END:
	973	.end
	974
	975	.sub test_ge_s_s_ic
	976	set $S0, "hello"
	977	set $S1, "hello"
	978	ge $S0, $S1, OK1
	979	branch ERROR
	980	OK1:
	981	set $S0, "hello"
	982	set $S1, "world"
	983	ge $S0, $S1, ERROR
	984	OK2:
	985	set $S0, "world"
	986	set $S1, "hello"
	987	ge $S0, $S1, OK3
	988	branch ERROR
	989	OK3:
	990	set $S0, "hello"
	991	set $S1, "hellooo"
	992	ge $S0, $S1, ERROR
	993	OK4:
	994	set $S0, "hellooo"
	995	set $S1, "hello"
	996	ge $S0, $S1, OK5
	997	branch ERROR
	998	OK5:
	999	set $S0, "hello"
	1000	set $S1, "hella"
	1001	ge $S0, $S1, OK6
	1002	branch ERROR
	1003	OK6:
	1004	set $S0, "hella"
	1005	set $S1, "hello"
	1006	ge $S0, $S1, ERROR
	1007	OK7:
	1008	set $S0, "hella"
	1009	set $S1, "hellooo"
	1010	ge $S0, $S1, ERROR
	1011	OK8:
	1012	set $S0, "hellooo"
	1013	set $S1, "hella"
	1014	ge $S0, $S1, OK9
	1015	branch ERROR
	1016	OK9:
	1017	set $S0, "hElLo"
	1018	set $S1, "HeLlO"
	1019	ge $S0, $S1, OK10
	1020	branch ERROR
	1021	OK10:
	1022	set $S0, "hElLo"
	1023	set $S1, "hElLo"
	1024	ge $S0, $S1, OK11
	1025	branch ERROR
	1026	OK11:
	1027	ok( 1, 'ge_s_s_ic' )
	1028	goto END
	1029	ERROR:
	1030	ok( 0, 'ge_s_s_ic' )
	1031	END:
	1032	.end
	1033
	1034	.sub test_ge_sc_s_ic
	1035	set $S0, "hello"
	1036	ge "hello", $S0, OK1
	1037	branch ERROR
	1038	OK1:
	1039	set $S0, "world"
	1040	ge "hello", $S0, ERROR
	1041	OK2:
	1042	set $S0, "hello"
	1043	ge "world", $S0, OK3
	1044	branch ERROR
	1045	OK3:
	1046	set $S0, "hellooo"
	1047	ge "hello", $S0, ERROR
	1048	OK4:
	1049	set $S0, "hello"
	1050	ge "hellooo", $S0, OK5
	1051	branch ERROR
	1052	OK5:
	1053	set $S0, "hella"
	1054	ge "hello", $S0, OK6
	1055	branch ERROR
	1056	OK6:
	1057	set $S0, "hello"
	1058	ge "hella", $S0, ERROR
	1059	OK7:
	1060	set $S0, "hellooo"
	1061	ge "hella", $S0, ERROR
	1062	OK8:
	1063	set $S0, "hella"
	1064	ge "hellooo", $S0, OK9
	1065	branch ERROR
	1066	OK9:
	1067	set $S0, "HeLlO"
	1068	ge "hElLo", $S0, OK10
	1069	branch ERROR
	1070	OK10:
	1071	set $S0, "hElLo"
	1072	ge "hElLo", $S0, OK11
	1073	branch ERROR
	1074	OK11:
	1075	ok( 1, 'ge_sc_s_ic' )
	1076	goto END
	1077	ERROR:
	1078	ok( 0, 'ge_sc_s_ic' )
	1079	END:
	1080	.end
	1081
	1082	.sub test_ge_s_sc_ic
	1083	set $S0, "hello"
	1084	ge $S0, "hello", OK1
	1085	branch ERROR
	1086	OK1:
	1087	set $S0, "hello"
	1088	ge $S0, "world", ERROR
	1089	OK2:
	1090	set $S0, "world"
	1091	ge $S0, "hello", OK3
	1092	branch ERROR
	1093	OK3:
	1094	set $S0, "hello"
	1095	ge $S0, "hellooo", ERROR
	1096	OK4:
	1097	set $S0, "hellooo"
	1098	ge $S0, "hello", OK5
	1099	branch ERROR
	1100	OK5:
	1101	set $S0, "hello"
	1102	ge $S0, "hella", OK6
	1103	branch ERROR
	1104	OK6:
	1105	set $S0, "hella"
	1106	ge $S0, "hello", ERROR
	1107	OK7:
	1108	set $S0, "hella"
	1109	ge $S0, "hellooo", ERROR
	1110	OK8:
	1111	set $S0, "hellooo"
	1112	ge $S0, "hella", OK9
	1113	branch ERROR
	1114	OK9:
	1115	set $S0, "hElLo"
	1116	ge $S0, "HeLlO", OK10
	1117	branch ERROR
	1118	OK10:
	1119	set $S0, "hElLo"
	1120	ge $S0, "hElLo", OK11
	1121	branch ERROR
	1122	OK11:
	1123	ok( 1, 'ge_s_sc_ic' )
	1124	goto END
	1125	ERROR:
	1126	ok( 0, 'ge_s_sc_ic' )
	1127	END:
	1128	.end
	1129
	1130	.sub test_ge_sc_sc_ic
	1131	ge "hello", "hello", OK1
	1132	branch ERROR
	1133	OK1:
	1134	ge "hello", "world", ERROR
	1135	OK2:
	1136	ge "world", "hello", OK3
	1137	branch ERROR
	1138	OK3:
	1139	ge "hello", "hellooo", ERROR
	1140	OK4:
	1141	ge "hellooo", "hello", OK5
	1142	branch ERROR
	1143	OK5:
	1144	ge "hello", "hella", OK6
	1145	branch ERROR
	1146	OK6:
	1147	ge "hella", "hello", ERROR
	1148	OK7:
	1149	ge "hella", "hellooo", ERROR
	1150	OK8:
	1151	ge "hellooo", "hella", OK9
	1152	branch ERROR
	1153	OK9:
	1154	ge "hElLo", "HeLlO", OK10
	1155	branch ERROR
	1156	OK10:
	1157	ge "hElLo", "hElLo", OK11
	1158	branch ERROR
	1159	OK11:
	1160	ok( 1, 'ge_sc_sc_ic' )
	1161	goto END
	1162	ERROR:
	1163	ok( 0, 'ge_sc_sc_ic' )
	1164	END:
	1165	.end
	1166
	1167
	1168	##### The above pir was generate from the following perl:
	1169	#
	1170	# #!/usr/bin/env perl
	1171	#
	1172	# use strict;
	1173	# use warnings;
	1174	#
	1175	# my ( $subs, $count, $calls );
	1176	#
	1177	# # Generate code to compare each pair of strings in a list
	1178	# sub compare_strings {
	1179	# my $const = shift;
	1180	# my $op = shift;
	1181	# my $desc = shift;
	1182	# my @strings = @_;
	1183	# my $i = 1;
	1184	# my $rt;
	1185	#
	1186	# $calls .= " test_${desc}()\n";
	1187	#
	1188	# $rt .= ".sub test_${desc}\n";
	1189	#
	1190	# while (@strings) {
	1191	# my $s1 = shift @strings;
	1192	# my $s2 = shift @strings;
	1193	# my $arg1;
	1194	# my $arg2;
	1195	# if ( $const == 3 ) {
	1196	# $arg1 = "\"$s1\"";
	1197	# $arg2 = "\"$s2\"";
	1198	# } elsif ( $const == 2 ) {
	1199	# $rt .= " set \$S0, \"$s1\"\n";
	1200	# $arg1 = "\$S0";
	1201	# $arg2 = "\"$s2\"";
	1202	# } elsif ( $const == 1 ) {
	1203	# $rt .= " set \$S0, \"$s2\"\n";
	1204	# $arg1 = "\"$s1\"";
	1205	# $arg2 = "\$S0";
	1206	# } else {
	1207	# $rt .= " set \$S0, \"$s1\"\n";
	1208	# $rt .= " set \$S1, \"$s2\"\n";
	1209	# $arg1 = "\$S0";
	1210	# $arg2 = "\$S1";
	1211	# }
	1212	# if ( eval "\"$s1\" $op \"$s2\"" ) {
	1213	# $rt .= " $op $arg1, $arg2, OK$i\n";
	1214	# $rt .= " branch ERROR\n";
	1215	# } else {
	1216	# $rt .= " $op $arg1, $arg2, ERROR\n";
	1217	# }
	1218	# $rt .= " OK$i:\n";
	1219	# $i++;
	1220	# }
	1221	#
	1222	# $rt .= " ok( 1, '$desc' )\n";
	1223	# $rt .= " goto END\n";
	1224	# $rt .= " ERROR:\n";
	1225	# $rt .= " ok( 0, '$desc' ) \n ";
	1226	# $rt .= " END:\n";
	1227	# $rt .= ".end\n\n";
	1228	# return $rt;
	1229	# }
	1230	# my @strings = (
	1231	# "hello", "hello", "hello", "world", "world", "hello",
	1232	# "hello", "hellooo", "hellooo", "hello", "hello", "hella",
	1233	# "hella", "hello", "hella", "hellooo", "hellooo", "hella",
	1234	# "hElLo", "HeLlO", "hElLo", "hElLo"
	1235	# );
	1236	#
	1237	# $count = 4 * 6;
	1238	# $subs .= compare_strings( 0, "eq", 'eq_s_s_ic', @strings, );
	1239	# $subs .= compare_strings( 1, "eq", 'eq_sc_s_ic', @strings, );
	1240	# $subs .= compare_strings( 2, "eq", 'eq_s_sc_ic', @strings, );
	1241	# $subs .= compare_strings( 3, "eq", 'eq_sc_sc_ic', @strings, );
	1242	# $subs .= compare_strings( 0, "ne", 'ne_s_s_ic', @strings, );
	1243	# $subs .= compare_strings( 1, "ne", 'ne_sc_s_ic', @strings, );
	1244	# $subs .= compare_strings( 2, "ne", 'ne_s_sc_ic', @strings, );
	1245	# $subs .= compare_strings( 3, "ne", 'ne_sc_sc_ic', @strings, );
	1246	# $subs .= compare_strings( 0, "lt", 'lt_s_s_ic', @strings, );
	1247	# $subs .= compare_strings( 1, "lt", 'lt_sc_s_ic', @strings, );
	1248	# $subs .= compare_strings( 2, "lt", 'lt_s_sc_ic', @strings, );
	1249	# $subs .= compare_strings( 3, "lt", 'lt_sc_sc_ic', @strings, );
	1250	# $subs .= compare_strings( 0, "le", 'le_s_s_ic', @strings, );
	1251	# $subs .= compare_strings( 1, "le", 'le_sc_s_ic', @strings, );
	1252	# $subs .= compare_strings( 2, "le", 'le_s_sc_ic', @strings, );
	1253	# $subs .= compare_strings( 3, "le", 'le_sc_sc_ic', @strings, );
	1254	# $subs .= compare_strings( 0, "gt", 'gt_s_s_ic', @strings, );
	1255	# $subs .= compare_strings( 1, "gt", 'gt_sc_s_ic', @strings, );
	1256	# $subs .= compare_strings( 2, "gt", 'gt_s_sc_ic', @strings, );
	1257	# $subs .= compare_strings( 3, "gt", 'gt_sc_sc_ic', @strings, );
	1258	# $subs .= compare_strings( 0, "ge", 'ge_s_s_ic', @strings, );
	1259	# $subs .= compare_strings( 1, "ge", 'ge_sc_s_ic', @strings, );
	1260	# $subs .= compare_strings( 2, "ge", 'ge_s_sc_ic', @strings, );
	1261	# $subs .= compare_strings( 3, "ge", 'ge_sc_sc_ic', @strings, );
	1262	#
	1263	# print <<TEMPLATE;
	1264	# #! parrot
	1265	# # Copyright (C) 2001-2009, Parrot Foundation.
	1266	# # \$Id: string.t 41325 2009-09-17 19:39:19Z NotFound \$
	1267	#
	1268	# =head1 NAME
	1269	#
	1270	# t/op/string.t - Parrot Strings
	1271	#
	1272	# =head1 SYNOPSIS
	1273	#
	1274	# % prove t/op/string.t
	1275	#
	1276	# =head1 DESCRIPTION
	1277	#
	1278	# Tests Parrot string registers and operations.
	1279	#
	1280	# =cut
	1281	#
	1282	# .sub main :main
	1283	# .include 'test_more.pir'
	1284	#
	1285	# plan($count)
	1286	#
	1287	# $calls
	1288	# .end
	1289	#
	1290	# $subs
	1291	#
	1292	# # Local Variables:
	1293	# # mode: pir
	1294	# # cperl-indent-level: 4
	1295	# # fill-column: 100
	1296	# # End:
	1297	# # vim: expandtab shiftwidth=4 ft=pir :
	1298	# TEMPLATE
	1299
	1300	# Local Variables:
	1301	# mode: pir
	1302	# cperl-indent-level: 4
	1303	# fill-column: 100
	1304	# End:
	1305	# vim: expandtab shiftwidth=4 ft=pir :

t/op/arithmetics.t


1		#!~~perl~~
2		# Copyright (C) 2001-2009, Parrot Foundation.
	1	#! parrot
	2	# Copyright (C) 2001-2008, Parrot Foundation.
3	3	# $Id$
4	4
5		~~use strict;~~
6		~~use warnings;~~
7		~~use lib qw( . lib ../lib ../../lib );~~
8
9		~~use Test::More;~~
10		~~use Parrot::Test tests => 21;~~
11
12		~~# test for GMP~~
13		~~use Parrot::Config;~~
14
15	5	=head1 NAME
16	6
17	7	t/op/arithmetics.t - Arithmetic Ops
…	…
27	17
28	18	=cut
29	19
	20	.sub main :main
	21	.include 'test_more.pir'
	22
	23	plan(125)
	24
	25	take_the_negative_of_a_native_integer()
	26	take_the_absolute_of_a_native_integer()
	27	add_native_integer_to_native_integer()
	28	subtract_native_integer_from_native_integer()
	29	multiply_native_integer_with_native_integer()
	30	divide_native_integer_by_native_integer()
	31	negate_minus_zero_point_zero()
	32	negate_a_native_number()
	33	take_the_absolute_of_a_native_number()
	34	ceil_of_a_native_number()
	35	floor_of_a_native_number()
	36	add_native_integer_to_native_number()
	37	subtract_native_integer_from_native_number()
	38	multiply_native_number_with_native_integer()
	39	divide_native_number_by_native_integer()
	40	add_native_number_to_native_number()
	41	subtract_native_number_from_native_number()
	42	multiply_native_number_with_native_number()
	43	divide_native_number_by_native_number()
	44	lcm_test()
	45	integer_overflow_with_pow()
	46	# END_OF_TESTS
	47
	48	.end
	49
30	50	#
31	51	# Operations on a single INTVAL
32	52	#
33		pasm_output_is( <<'CODE', <<OUTPUT, "take the negative of a native integer" );
34		set I0, 0
35		neg I0
36		say I0
37		set I0, 1234567890
38		neg I0
39		say I0
40		set I0, -1234567890
41		neg I0
42		say I0
43		set I0, 0
44		set I1, 0
45		neg I1, I0
46		say I1
47		set I0, 1234567890
48		neg I1, I0
49		say I1
50		set I0, -1234567890
51		neg I1, I0
52		say I1
53		end
54		CODE
55		0
56		-1234567890
57		1234567890
58		0
59		-1234567890
60		1234567890
61		OUTPUT
	53	.sub take_the_negative_of_a_native_integer
	54	set $I0, 0
	55	neg $I0
	56	is( $I0, "0", 'take_the_negative_of_a_native_integer' )
62	57
63		pasm_output_is( <<'CODE', <<OUTPUT, "take the absolute of a native integer" );
64		set I0, 0
65		abs I0
66		say I0
67		set I0, 1234567890
68		abs I0
69		say I0
70		set I0, -1234567890
71		abs I0
72		say I0
73		set I0, 0
74		set I1, 0
75		abs I1, I0
76		say I1
77		set I0, 1234567890
78		abs I1, I0
79		say I1
80		set I0, -1234567890
81		abs I1, I0
82		say I1
83		end
84		CODE
85		0
86		1234567890
87		1234567890
88		0
89		1234567890
90		1234567890
91		OUTPUT
	58	set $I0, 1234567890
	59	neg $I0
	60	is( $I0, "-1234567890", 'take_the_negative_of_a_native_integer' )
	61
	62	set $I0, -1234567890
	63	neg $I0
	64	is( $I0, "1234567890", 'take_the_negative_of_a_native_integer' )
	65
	66	set $I0, 0
	67	set $I1, 0
	68	neg $I1, $I0
	69	is( $I1, "0", 'take_the_negative_of_a_native_integer' )
	70
	71	set $I0, 1234567890
	72	neg $I1, $I0
	73	is( $I1, "-1234567890", 'take_the_negative_of_a_native_integer' )
	74
	75	set $I0, -1234567890
	76	neg $I1, $I0
	77	is( $I1, "1234567890", 'take_the_negative_of_a_native_integer' )
	78	.end
92	79
	80	.sub take_the_absolute_of_a_native_integer
	81	set $I0, 0
	82	abs $I0
	83	is( $I0, "0", 'take_the_absolute_of_a_native_integer' )
	84
	85	set $I0, 1234567890
	86	abs $I0
	87	is( $I0, "1234567890", 'take_the_absolute_of_a_native_integer' )
	88
	89	set $I0, -1234567890
	90	abs $I0
	91	is( $I0, "1234567890", 'take_the_absolute_of_a_native_integer' )
	92
	93	set $I0, 0
	94	set $I1, 0
	95	abs $I1, $I0
	96	is( $I1, "0", 'take_the_absolute_of_a_native_integer' )
	97
	98	set $I0, 1234567890
	99	abs $I1, $I0
	100	is( $I1, "1234567890", 'take_the_absolute_of_a_native_integer' )
	101
	102	set $I0, -1234567890
	103	abs $I1, $I0
	104	is( $I1, "1234567890", 'take_the_absolute_of_a_native_integer' )
	105	.end
	106
93	107	#
94	108	# first arg is INTVAL, second arg is INTVAL
95	109	#
96		pasm_output_is( <<'CODE', <<OUTPUT, "add native integer to native integer" );
97		set I0, 4000
98		set I1, -123
99		add I2, I0, I1
100		say I2
101		add I0, I0, I1
102		say I0
103		end
104		CODE
105		3877
106		3877
107		OUTPUT
	110	.sub add_native_integer_to_native_integer
	111	set $I0, 4000
	112	set $I1, -123
	113	add $I2, $I0, $I1
	114	is( $I2, "3877", 'add_native_integer_to_native_integer' )
108	115
109		pasm_output_is( <<'CODE', <<OUTPUT, "subtract native integer from native integer" );
110		set I0, 4000
111		set I1, -123
112		sub I2, I0, I1
113		say I2
114		sub I0, I0, I1
115		say I0
116		end
117		CODE
118		4123
119		4123
120		OUTPUT
	116	add $I0, $I0, $I1
	117	is( $I0, "3877", 'add_native_integer_to_native_integer' )
	118	.end
	119
	120	.sub subtract_native_integer_from_native_integer
	121	set $I0, 4000
	122	set $I1, -123
	123	sub $I2, $I0, $I1
	124	is( $I2, "4123", 'subtract_native_integer_from_native_integer' )
121	125
122		pasm_output_is( <<'CODE', <<OUTPUT, "multiply native integer with native integer" );
123		set I0, 4000
124		set I1, -123
125		mul I2, I0, I1
126		say I2
127		mul I0, I0, I1
128		say I0
129		end
130		CODE
131		-492000
132		-492000
133		OUTPUT
	126	sub $I0, $I0, $I1
	127	is( $I0, "4123", 'subtract_native_integer_from_native_integer' )
	128	.end
	129
	130	.sub multiply_native_integer_with_native_integer
	131	set $I0, 4000
	132	set $I1, -123
	133	mul $I2, $I0, $I1
	134	is( $I2, "-492000", 'multiply_native_integer_with_native_integer' )
134	135
135		pasm_output_is( <<'CODE', <<OUTPUT, "divide native integer by native integer" );
136		set I0, 4000
137		set I1, -123
138		div I2, I0, I1
139		say I2
140		div I0, I0, I1
141		say I0
142		end
143		CODE
144		-32
145		-32
146		OUTPUT
	136	mul $I0, $I0, $I1
	137	is( $I0, "-492000", 'multiply_native_integer_with_native_integer' )
	138	.end
	139
	140	.sub divide_native_integer_by_native_integer
	141	set $I0, 4000
	142	set $I1, -123
	143	div $I2, $I0, $I1
	144	is( $I2, "-32", 'divide_native_integer_by_native_integer' )
147	145
	146	div $I0, $I0, $I1
	147	is( $I0, "-32", 'divide_native_integer_by_native_integer' )
	148	.end
	149
148	150	#
149	151	# print -0.0 as -0
150	152	#
	153	.sub negate_minus_zero_point_zero
	154	set $N0, 0
	155	neg $N0
	156	$S0 = $N0
	157	is( $S0, "-0", '1' )
151	158
152		pasm_output_is( <<'CODE', <<OUTPUT, 'negate -0.0' );
153		set N0, 0
154		neg N0
155		say N0
156		set N0, -0.0
157		neg N0
158		say N0
159		set N0, -0.0
160		neg N1, N0
161		say N1
162		set N0, 0
163		set N1, 1
164		neg N1, N0
165		say N1
166		end
167		CODE
168		-0
169		0
170		0
171		-0
172		OUTPUT
	159	set $N0, -0.0
	160	neg $N0
	161	$S0 = $N0
	162	is( $S0, "0", '2' )
173	163
	164	set $N0, -0.0
	165	neg $N1, $N0
	166	$S0 = $N1
	167	is( $S0, "0", '3' )
174	168
175
	169	set $N0, 0
	170	set $N1, 1
	171	neg $N1, $N0
	172	$S0 = $N1
	173	is( $S0, "-0", '4' )
	174	.end
	175
176	176	#
177	177	# Operations on a single NUMVAL
178	178	#
	179	.sub negate_a_native_number
	180	set $N0, 123.4567890
	181	neg $N0
	182	is( $N0, "-123.456789", 'negate_a_native_number' )
179	183
180		pasm_output_is( <<'CODE', <<OUTPUT, 'negate a native number' );
181		set N0, 123.4567890
182		neg N0
183		say N0
184		set N0, -123.4567890
185		neg N0
186		say N0
187		set N0, 123.4567890
188		neg N1, N0
189		say N1
190		set N0, -123.4567890
191		neg N1, N0
192		say N1
193		end
194		CODE
195		-123.456789
196		123.456789
197		-123.456789
198		123.456789
199		OUTPUT
	184	set $N0, -123.4567890
	185	neg $N0
	186	is( $N0, "123.456789", 'negate_a_native_number' )
200	187
201		pasm_output_is( <<'CODE', <<OUTPUT, "take the absolute of a native number" );
202		set N0, 0
203		abs N0
204		say N0
205		set N0, -0.0
206		abs N0
207		say N0
208		set N0, 123.45678901
209		abs N0
210		say N0
211		set N0, -123.45678901
212		abs N0
213		say N0
214		set N0, 0
215		set N1, 1
216		abs N1, N0
217		say N1
218		set N0, 0.0
219		set N1, 1
220		abs N1, N0
221		say N1
222		set N0, 123.45678901
223		set N1, 1
224		abs N1, N0
225		say N1
226		set N0, -123.45678901
227		set N1, 1
228		abs N1, N0
229		say N1
230		end
231		CODE
232		0
233		0
234		123.45678901
235		123.45678901
236		0
237		0
238		123.45678901
239		123.45678901
240		OUTPUT
	188	set $N0, 123.4567890
	189	neg $N1, $N0
	190	is( $N1, "-123.456789", 'negate_a_native_number' )
241	191
242		pasm_output_is( <<'CODE', <<OUTPUT, "ceil of a native number" );
243		set N0, 0
244		ceil N0
245		say N0
246		set N0, 123.45678901
247		ceil N0
248		say N0
249		set N0, -123.45678901
250		ceil N0
251		say N0
252		set N0, 0
253		set N1, 1
254		ceil N1, N0
255		say N1
256		set N0, 0.0
257		set N1, 1
258		ceil N1, N0
259		say N1
260		set N0, 123.45678901
261		set N1, 1
262		ceil N1, N0
263		say N1
264		set N0, -123.45678901
265		set N1, 1
266		ceil N1, N0
267		say N1
268		set N0, 0
269		set I1, 1
270		ceil I1, N0
271		say I1
272		set N0, 0.0
273		set I1, 1
274		ceil I1, N0
275		say I1
276		set N0, 123.45678901
277		set I1, 1
278		ceil I1, N0
279		say I1
280		set N0, -123.45678901
281		set I1, 1
282		ceil I1, N0
283		say I1
284		end
285		CODE
286		0
287		124
288		-123
289		0
290		0
291		124
292		-123
293		0
294		0
295		124
296		-123
297		OUTPUT
	192	set $N0, -123.4567890
	193	neg $N1, $N0
	194	is( $N1, "123.456789", 'negate_a_native_number' )
	195	.end
	196
	197	.sub take_the_absolute_of_a_native_number
	198	set $N0, 0
	199	abs $N0
	200	is( $N0, "0", 'take_the_absolute_of_a_native_number' )
298	201
299		pasm_output_is( <<'CODE', <<OUTPUT, "floor of a native number" );
300		set N0, 0
301		floor N0
302		say N0
303		set N0, 123.45678901
304		floor N0
305		say N0
306		set N0, -123.45678901
307		floor N0
308		say N0
309		set N0, 0
310		set N1, 1
311		floor N1, N0
312		say N1
313		set N0, 0.0
314		set N1, 1
315		floor N1, N0
316		say N1
317		set N0, 123.45678901
318		set N1, 1
319		floor N1, N0
320		say N1
321		set N0, -123.45678901
322		set N1, 1
323		floor N1, N0
324		say N1
325		set N0, 0
326		set I1, 1
327		floor I1, N0
328		say I1
329		set N0, 0.0
330		set I1, 1
331		floor I1, N0
332		say I1
333		set N0, 123.45678901
334		set I1, 1
335		floor I1, N0
336		say I1
337		set N0, -123.45678901
338		set I1, 1
339		floor I1, N0
340		say I1
341		end
342		CODE
343		0
344		123
345		-124
346		0
347		0
348		123
349		-124
350		0
351		0
352		123
353		-124
354		OUTPUT
	202	set $N0, -0.0
	203	abs $N0
	204	is( $N0, "0", 'take_the_absolute_of_a_native_number' )
355	205
	206	set $N0, 123.45678901
	207	abs $N0
	208	is( $N0, "123.45678901", 'take_the_absolute_of_a_native_number' )
	209
	210	set $N0, -123.45678901
	211	abs $N0
	212	is( $N0, "123.45678901", 'take_the_absolute_of_a_native_number' )
	213
	214	set $N0, 0
	215	set $N1, 1
	216	abs $N1, $N0
	217	is( $N1, "0", 'take_the_absolute_of_a_native_number' )
	218
	219	set $N0, 0.0
	220	set $N1, 1
	221	abs $N1, $N0
	222	is( $N1, "0", 'take_the_absolute_of_a_native_number' )
	223
	224	set $N0, 123.45678901
	225	set $N1, 1
	226	abs $N1, $N0
	227	is( $N1, "123.45678901", 'take_the_absolute_of_a_native_number' )
	228
	229	set $N0, -123.45678901
	230	set $N1, 1
	231	abs $N1, $N0
	232	is( $N1, "123.45678901", 'take_the_absolute_of_a_native_number' )
	233	.end
	234
	235	.sub ceil_of_a_native_number
	236	set $N0, 0
	237	ceil $N0
	238	is( $N0, "0", 'ceil_of_a_native_number' )
	239
	240	set $N0, 123.45678901
	241	ceil $N0
	242	is( $N0, "124", 'ceil_of_a_native_number' )
	243
	244	set $N0, -123.45678901
	245	ceil $N0
	246	is( $N0, "-123", 'ceil_of_a_native_number' )
	247
	248	set $N0, 0
	249	set $N1, 1
	250	ceil $N1, $N0
	251	is( $N1, "0", 'ceil_of_a_native_number' )
	252
	253	set $N0, 0.0
	254	set $N1, 1
	255	ceil $N1, $N0
	256	is( $N1, "0", 'ceil_of_a_native_number' )
	257
	258	set $N0, 123.45678901
	259	set $N1, 1
	260	ceil $N1, $N0
	261	is( $N1, "124", 'ceil_of_a_native_number' )
	262
	263	set $N0, -123.45678901
	264	set $N1, 1
	265	ceil $N1, $N0
	266	is( $N1, "-123", 'ceil_of_a_native_number' )
	267
	268	set $N0, 0
	269	set $I1, 1
	270	ceil $I1, $N0
	271	is( $I1, "0", 'ceil_of_a_native_number' )
	272
	273	set $N0, 0.0
	274	set $I1, 1
	275	ceil $I1, $N0
	276	is( $I1, "0", 'ceil_of_a_native_number' )
	277
	278	set $N0, 123.45678901
	279	set $I1, 1
	280	ceil $I1, $N0
	281	is( $I1, "124", 'ceil_of_a_native_number' )
	282
	283	set $N0, -123.45678901
	284	set $I1, 1
	285	ceil $I1, $N0
	286	is( $I1, "-123", 'ceil_of_a_native_number' )
	287	.end
	288
	289	.sub floor_of_a_native_number
	290	set $N0, 0
	291	floor $N0
	292	is( $N0, "0", 'floor_of_a_native_number' )
	293
	294	set $N0, 123.45678901
	295	floor $N0
	296	is( $N0, "123", 'floor_of_a_native_number' )
	297
	298	set $N0, -123.45678901
	299	floor $N0
	300	is( $N0, "-124", 'floor_of_a_native_number' )
	301
	302	set $N0, 0
	303	set $N1, 1
	304	floor $N1, $N0
	305	is( $N1, "0", 'floor_of_a_native_number' )
	306
	307	set $N0, 0.0
	308	set $N1, 1
	309	floor $N1, $N0
	310	is( $N1, "0", 'floor_of_a_native_number' )
	311
	312	set $N0, 123.45678901
	313	set $N1, 1
	314	floor $N1, $N0
	315	is( $N1, "123", 'floor_of_a_native_number' )
	316
	317	set $N0, -123.45678901
	318	set $N1, 1
	319	floor $N1, $N0
	320	is( $N1, "-124", 'floor_of_a_native_number' )
	321
	322	set $N0, 0
	323	set $I1, 1
	324	floor $I1, $N0
	325	is( $I1, "0", 'floor_of_a_native_number' )
	326
	327	set $N0, 0.0
	328	set $I1, 1
	329	floor $I1, $N0
	330	is( $I1, "0", 'floor_of_a_native_number' )
	331
	332	set $N0, 123.45678901
	333	set $I1, 1
	334	floor $I1, $N0
	335	is( $I1, "123", 'floor_of_a_native_number' )
	336
	337	set $N0, -123.45678901
	338	set $I1, 1
	339	floor $I1, $N0
	340	is( $I1, "-124", 'floor_of_a_native_number' )
	341
	342	.end
	343
356	344	#
357	345	# FLOATVAL and INTVAL tests
358	346	#
359		pasm_output_is( <<'CODE', <<OUTPUT, "add native integer to native number" );
360		set I0, 4000
361		set N0, -123.123
362		add N1, N0, I0
363		say N1
364		add N0, N0, I0
365		say N0
366		add N0, I0
367		say N0
368		end
369		CODE
370		3876.877
371		3876.877
372		7876.877
373		OUTPUT
	347	.sub add_native_integer_to_native_number
	348	set $I0, 4000
	349	set $N0, -123.123
	350	add $N1, $N0, $I0
	351	is( $N1, "3876.877", 'add_native_integer_to_native_number' )
374	352
375		pasm_output_is( <<'CODE', <<OUTPUT, "subtract native integer from native number" );
376		set I0, 4000
377		set N0, -123.123
378		sub N1, N0, I0
379		say N1
380		sub N0, N0, I0
381		say N0
382		sub N0, I0
383		say N0
384		end
385		CODE
386		-4123.123
387		-4123.123
388		-8123.123
389		OUTPUT
	353	add $N0, $N0, $I0
	354	is( $N0, "3876.877", 'add_native_integer_to_native_number' )
390	355
391		pasm_output_is( <<'CODE', <<OUTPUT, "multiply native number with native integer" );
392		set I0, 4000
393		set N0, -123.123
394		mul N1, N0, I0
395		say N1
396		mul N0, N0, I0
397		say N0
398		mul N0, -2
399		say N0
400		end
401		CODE
402		-492492
403		-492492
404		984984
405		OUTPUT
	356	add $N0, $I0
	357	is( $N0, "7876.877", 'add_native_integer_to_native_number' )
406	358
407		pasm_output_is( <<'CODE', <<OUTPUT, "divide native number by native integer" );
408		set I0, 4000
409		set N0, -123.123
410		div N1, N0, I0
411		say N1
412		div N0, N0, I0
413		say N0
414		div N0, 1
415		say N0
416		set N0, 100.000
417		div N0, 100
418		say N0
419		div N0, 0.01
420		say N0
421		end
422		CODE
423		-0.03078075
424		-0.03078075
425		-0.03078075
426		1
427		100
428		OUTPUT
	359	.end
	360
	361	.sub subtract_native_integer_from_native_number
	362	set $I0, 4000
	363	set $N0, -123.123
	364	sub $N1, $N0, $I0
	365	is( $N1, "-4123.123", 'subtract_native_integer_from_native_number' )
429	366
	367	sub $N0, $N0, $I0
	368	is( $N0, "-4123.123", 'subtract_native_integer_from_native_number' )
	369
	370	sub $N0, $I0
	371	is( $N0, "-8123.123", 'subtract_native_integer_from_native_number' )
	372
	373	.end
	374
	375	.sub multiply_native_number_with_native_integer
	376	set $I0, 4000
	377	set $N0, -123.123
	378	mul $N1, $N0, $I0
	379	is( $N1, "-492492", 'multiply_native_number_with_native_integer' )
	380
	381	mul $N0, $N0, $I0
	382	is( $N0, "-492492", 'multiply_native_number_with_native_integer' )
	383
	384	mul $N0, -2
	385	is( $N0, "984984", 'multiply_native_number_with_native_integer' )
	386	.end
	387
	388	.sub divide_native_number_by_native_integer
	389	set $I0, 4000
	390	set $N0, -123.123
	391	div $N1, $N0, $I0
	392	is( $N1, "-0.03078075", 'divide_native_number_by_native_integer' )
	393
	394	div $N0, $N0, $I0
	395	is( $N0, "-0.03078075", 'divide_native_number_by_native_integer' )
	396
	397	div $N0, 1
	398	is( $N0, "-0.03078075", 'divide_native_number_by_native_integer' )
	399
	400	set $N0, 100.000
	401	div $N0, 100
	402	is( $N0, "1", 'divide_native_number_by_native_integer' )
	403
	404	div $N0, 0.01
	405	is( $N0, "100", 'divide_native_number_by_native_integer' )
	406	.end
	407
430	408	#
431	409	# FLOATVAL and FLOATVAL tests
432	410	#
433		pasm_output_is( <<'CODE', <<OUTPUT, "add native number to native number" );
434		set N2, 4000.246
435		set N0, -123.123
436		add N1, N0, N2
437		say N1
438		add N0, N0, N2
439		say N0
440		end
441		CODE
442		3877.123
443		3877.123
444		OUTPUT
	411	.sub add_native_number_to_native_number
	412	set $N2, 4000.246
	413	set $N0, -123.123
	414	add $N1, $N0, $N2
	415	is( $N1, "3877.123", 'add_native_number_to_native_number' )
445	416
446		pasm_output_is( <<'CODE', <<OUTPUT, "subtract native number from native number" );
447		set N2, 4000.246
448		set N0, -123.123
449		sub N1, N0, N2
450		say N1
451		sub N0, N0, N2
452		say N0
453		end
454		CODE
455		-4123.369
456		-4123.369
457		OUTPUT
	417	add $N0, $N0, $N2
	418	is( $N0, "3877.123", 'add_native_number_to_native_number' )
	419	.end
	420
	421	.sub subtract_native_number_from_native_number
	422	set $N2, 4000.246
	423	set $N0, -123.123
	424	sub $N1, $N0, $N2
	425	is( $N1, "-4123.369", 'subtract_native_number_from_native_number' )
458	426
459		pasm_output_is( <<'CODE', <<OUTPUT, "multiply native number with native number" );
460		set N2, 4000.246
461		set N0, -123.123
462		mul N1, N0, N2
463		say N1
464		mul N0, N0, N2
465		say N0
466		end
467		CODE
468		-492522.288258
469		-492522.288258
470		OUTPUT
	427	sub $N0, $N0, $N2
	428	is( $N0, "-4123.369", 'subtract_native_number_from_native_number' )
471	429
472		pasm_output_is( <<'CODE', <<OUTPUT, "divide native number by native number" );
473		set N2, 4000.246
474		set N0, -123.123
475		div N1, N0, N2
476		say N1
477		div N0, N0, N2
478		say N0
479		end
480		CODE
481		-0.0307788571002883
482		-0.0307788571002883
483		OUTPUT
	430	.end
	431
	432	.sub multiply_native_number_with_native_number
	433	set $N2, 4000.246
	434	set $N0, -123.123
	435	mul $N1, $N0, $N2
	436	is( $N1, "-492522.288258", 'multiply_native_number_with_native_number' )
484	437
485		pasm_output_is( <<'CODE', <<OUTPUT, "lcm_I_I_I" );
486		set I0, 10
487		set I1, 10
488		lcm I2, I1, I0
489		eq I2, 10, OK1
490		print "not "
491		OK1: say "ok 1"
	438	mul $N0, $N0, $N2
	439	is( $N0, "-492522.288258", 'multiply_native_number_with_native_number' )
492	440
493		set I1, 17
494		lcm I2, I1, I0
495		eq I2, 170, OK2
496		print I2
497		print "not "
498		OK2: print "ok 2\n"
	441	.end
	442
	443	.sub divide_native_number_by_native_number
	444	set $N2, 4000.246
	445	set $N0, -123.123
	446	div $N1, $N0, $N2
	447	is( $N1, "-0.0307788571002883", 'divide_native_number_by_native_number' )
499	448
500		set I0, 17
501		set I1, 10
502		lcm I2, I1, I0
503		eq I2, 170, OK3
504		print "not "
505		OK3: print "ok 3\n"
	449	div $N0, $N0, $N2
	450	is( $N0, "-0.0307788571002883", 'divide_native_number_by_native_number' )
506	451
507		set I0, 10
508		set I1, 0
509		lcm I2, I1, I0
510		eq I2, 0, OK4
511		print "not "
512		OK4: print "ok 4\n"
	452	.end
	453
	454	.sub lcm_test
	455	set $I0, 10
	456	set $I1, 10
	457	lcm $I2, $I1, $I0
	458	is( $I2, 10, 'lcm_test' )
513	459
514		set I0, 0
515		set I1, 10
516		lcm I2, I1, I0
517		eq I2, 0, OK5
518		print "not "
519		OK5: print "ok 5\n"
	460	set $I1, 17
	461	lcm $I2, $I1, $I0
	462	is( $I2, 170, 'lcm_test' )
520	463
521		end
522		CODE
523		ok 1
524		ok 2
525		ok 3
526		ok 4
527		ok 5
528		OUTPUT
	464	set $I0, 17
	465	set $I1, 10
	466	lcm $I2, $I1, $I0
	467	is( $I2, 170, 'lcm_test' )
529	468
530		SKIP: {
531		skip( 'No integer overflow for 32-bit INTVALs without GMP installed', 1 )
532		if $PConfig{intvalsize} == 4 && !$PConfig{gmp};
	469	set $I0, 10
	470	set $I1, 0
	471	lcm $I2, $I1, $I0
	472	is( $I2, 0, 'lcm_test' )
533	473
534		pir_output_is( <<'CODE', <<OUTPUT, "integer overflow with 'pow'" );
535		.sub main
	474	set $I0, 0
	475	set $I1, 10
	476	lcm $I2, $I1, $I0
	477	is( $I2, 0, 'lcm_test' )
	478	.end
	479
	480	.sub integer_overflow_with_pow
	481	.include "iglobals.pasm"
	482
	483	# Check that we aren't 32-bit INTVALs without GMP
	484	.local pmc interp # a handle to our interpreter object.
	485	interp = getinterp
	486	.local pmc config
	487	config = interp[.IGLOBALS_CONFIG_HASH]
	488	.local int intvalsize
	489	intvalsize = config['intvalsize']
	490	.local int gmp
	491	gmp = config['gmp']
	492
	493	if intvalsize != 4 goto can_test
	494	if gmp goto can_test
	495	skip(40,'No integer overflow for 32-bit INTVALs without GMP installed')
	496	goto end
	497
	498	can_test:
	499
536	500	.local pmc i1, i2, r
537	501	i1 = new 'Integer'
538	502	i2 = new 'Integer'
539	503	i1 = 2
540	504	i2 = 1
541		next:
	505	$I1 = 1
	506	next:
542	507	null r
543	508	r = pow i1, i2
544	509	$S0 = r
545		say $S0
	510
	511	$I1 = $I1 * 2
	512	is( $S0, $I1, 'integer_overflow_with_pow' )
	513
546	514	inc i2
547	515	# XXX: this must be extended to at least 64 bit range
548	516	# when sure that the result is not floating point.
549	517	# In the meantime, make sure it overflows nicely
550	518	# on 32 bit.
551	519	unless i2 > 40 goto next
	520
	521	end:
552	522	.end
553		~~CODE~~
554		2
555		4
556		8
557		16
558		32
559		64
560		~~128~~
561		~~256~~
562		~~512~~
563		~~1024~~
564		~~2048~~
565		~~4096~~
566		~~8192~~
567		~~16384~~
568		~~32768~~
569		~~65536~~
570		~~131072~~
571		~~262144~~
572		~~524288~~
573		~~1048576~~
574		~~2097152~~
575		~~4194304~~
576		~~8388608~~
577		~~16777216~~
578		~~33554432~~
579		~~67108864~~
580		~~134217728~~
581		~~268435456~~
582		~~536870912~~
583		~~1073741824~~
584		~~2147483648~~
585		~~4294967296~~
586		~~8589934592~~
587		~~17179869184~~
588		~~34359738368~~
589		~~68719476736~~
590		~~137438953472~~
591		~~274877906944~~
592		~~549755813888~~
593		~~1099511627776~~
594		~~OUTPUT~~
595		}
596	523
597
598	524	# Local Variables:
599		# mode: ~~cperl~~
	525	# mode: pir
600	526	# cperl-indent-level: 4
601	527	# fill-column: 100
602	528	# End:
603		# vim: expandtab shiftwidth=4:
	529	# vim: expandtab shiftwidth=4 ft=pir :

Download in other formats:

Original Format